diff --git a/.github/environment/pixi.toml b/.github/environment/pixi.toml index 45e30589..e6c46347 100644 --- a/.github/environment/pixi.toml +++ b/.github/environment/pixi.toml @@ -11,9 +11,10 @@ platforms = [ devtools_document = "cd $GITHUB_WORKSPACE; R -e 'devtools::document()'" devtools_test = "cd $GITHUB_WORKSPACE; R -e 'devtools::test(stop_on_failure = TRUE)'" codecov = "cd $GITHUB_WORKSPACE; R -e 'covr::codecov(quiet = FALSE)'" -rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck()'" -bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone()'" -bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck()'" +rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck(error_on = \"error\", args = c(\"--no-manual\", \"--no-build-vignettes\"))'" +bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone(\"quit-with-status\" = TRUE)'" +bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck(\"quit-with-status\" = FALSE)'" +goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\")'" use_major_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"major\", push = FALSE)'" use_minor_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"minor\", push = FALSE)'" use_patch_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"patch\", push = FALSE)'" diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 24000827..0b9aaf02 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -12,23 +12,23 @@ concurrency: jobs: ci: - name: CI (${{ matrix.platform }} / ${{ matrix.environment }}) + name: ${{ matrix.name }} (${{ matrix.platform }} / ${{ matrix.environment }}) runs-on: ${{ matrix.runner }} env: CODECOV_TOKEN: ${{ secrets.CODECOV_TOKEN }} strategy: fail-fast: false matrix: - runner: [ubuntu-latest, macos-latest, ubuntu-24.04-arm] - environment: ["r45"] include: - - runner: ubuntu-latest - platform: linux-64 - - runner: ubuntu-24.04-arm - platform: linux-aarch64 - - runner: macos-latest - platform: osx-arm64 - + - { name: Run unit tests, task: devtools_test, platform: linux-aarch64, runner: ubuntu-24.04-arm, environment: r45 } + - { name: Run unit tests, task: devtools_test, platform: osx-arm64, runner: macos-latest, environment: r45 } + - { name: Run unit tests, task: devtools_test, platform: linux-64, -aarch64, runner: ubuntu-24.04-arm, environment: r45 } + - { name: Check code coverage with covr, task: codecov, platform: linux-64, runner: ubuntu-latest, environment: r45 } + - { name: Run R CMD check, task: rcmdcheck, platform: linux-64, runner: ubuntu-latest, environment: r45 } + - { name: Run BiocCheckGitClone, task: bioccheck_git_clone, platform: linux-64, runner: ubuntu-latest, environment: r45 } + - { name: Run BiocCheck, task: bioccheck, platform: linux-64, runner: ubuntu-latest, environment: r45 } + - { name: Check goodpractice, task: goodpractice, platform: linux-64, runner: ubuntu-latest, environment: r45 } + - { name: Check pkgdown_build, task: pkgdown_build, platform: linux-64, runner: ubuntu-latest, environment: r45 } steps: - name: Checkout pull request branch uses: actions/checkout@v7 @@ -46,20 +46,8 @@ jobs: with: manifest-path: /tmp/pixi/pixi.toml - - name: Run unit tests - run: | - pixi config set --manifest-path /tmp/pixi/pixi.toml --local run-post-link-scripts insecure - pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml devtools_test - - - name: Check unit test code coverage - if: matrix.platform == 'linux-64' - run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml codecov - - #- name: Run R CMD CHECK - #run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml rcmdcheck - - #- name: Run BiocCheckGitClone - #run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml bioccheck_git_clone + - name: Allow post-link scripts + run: pixi config set --manifest-path /tmp/pixi/pixi.toml --local run-post-link-scripts insecure - #- name: Run BiocCheck - #run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml bioccheck + - name: ${{ matrix.name }} + run: pixi run --environment ${{ matrix.environment }} --manifest-path /tmp/pixi/pixi.toml ${{ matrix.task }} diff --git a/DESCRIPTION b/DESCRIPTION index fae439ff..b51051ee 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -133,9 +133,9 @@ Collate: 'AnnotationMatrix.R' 'ColocResult.R' 'ColocBoostResult.R' + 'CtwasResultEntry.R' 'tupleSelectors.R' 'CtwasResult.R' - 'CtwasResultEntry.R' 'GenotypeDosageSeed.R' 'GwasFineMappingResult.R' 'MethodOptions.R' diff --git a/NAMESPACE b/NAMESPACE index ba225bc3..73488ae1 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -13,21 +13,8 @@ S3method(postprocessFinemappingFit,susie) S3method(postprocessFinemappingFit,susieInf) S3method(postprocessFinemappingFit,susieRss) export("af<-") -export("credibleSetParam<-") -export("csCoverage<-") -export("fineMappingMethods<-") -export("fitRetention<-") -export("includeAllCs<-") -export("initializeWithSusieInf<-") export("maf<-") -export("medianAbsCorr<-") -export("minAbsCorr<-") -export("nSamples<-") -export("panelFilterParam<-") -export("perCsColumns<-") -export("secondaryCoverage<-") -export("signalCutoff<-") -export("susieRssParam<-") +export("sampleSize<-") export(AnnotationMatrix) export(AspuOptions) export(BglrOptions) @@ -63,6 +50,7 @@ export(DentistParam) export(DprOptions) export(EnsembleParam) export(FineMappingMethodsParam) +export(FineMappingRow) export(FsusieOptions) export(GbjOmniOptions) export(GbjOptions) @@ -102,6 +90,7 @@ export(MvsusieRssOptions) export(NcvregOptions) export(PanelFilterParam) export(PenalizedRssOptions) +export(PhenotypeFilterParam) export(PlinkQcOptions) export(PoolrOptions) export(PrsCsOptions) @@ -134,6 +123,7 @@ export(SusieRssOptions) export(SusieRssParam) export(TwasWeights) export(TwasWeightsMethodsParam) +export(TwasWeightsRow) export(UdFitOptions) export(UdInitOptions) export(VariantPruningParam) @@ -143,7 +133,6 @@ export(annotCols) export(annotData) export(annotationJackknifeCoefs) export(asCtwasResult) -export(asGranges) export(assembleCtwasInputs) export(autoDecision) export(bLassoWeights) @@ -170,6 +159,7 @@ export(colocCredibleSets) export(colocGenes) export(colocPairs) export(colocPipeline) +export(colocPooledVariants) export(colocVariants) export(colocboostPipeline) export(combineFineMappingResults) @@ -204,6 +194,7 @@ export(dprVbWeights) export(dprWeights) export(effectiveN) export(eigenList) +export(enetRssWeights) export(enetWeights) export(enforceDesignFullRank) export(enlocClusterProbabilities) @@ -211,10 +202,9 @@ export(ensembleWeights) export(estCtwasGroupPriors) export(estimateH2) export(estimateSparsity) -export(exportToBed) -export(exportToVcf) export(extractCsInfo) export(extractTopPipInfo) +export(fillFromReference) export(filterInvalidSummaryStat) export(filterMixtureComponents) export(filterRelatedness) @@ -222,7 +212,6 @@ export(filterVariantsByLdReference) export(fineMappingMethods) export(fineMappingPipeline) export(fineMappingResult) -export(fineMappingRow) export(finemapCtwasRegions) export(fitFsusie) export(fitGlmnetCv) @@ -249,15 +238,12 @@ export(heritabilityEstimate) export(heritabilityEstimateSe) export(heritabilityIntercept) export(heritabilityInterceptSe) -export(imissCutoff) export(inSample) export(includeAllCs) export(initializeWithSusieInf) export(intersectVariants) export(invertMinmaxScaling) export(isBinarySldscAnnot) -export(keepIndel) -export(keepVariants) export(krigingOutlierQc) export(l0learnRssWeights) export(l0learnWeights) @@ -280,9 +266,7 @@ export(loadMultiStudyQtlDatasetFromManifest) export(loadQtlDatasetFromManifest) export(loadQtlSumStatsFromManifest) export(localH2Blocks) -export(macCutoff) export(maf) -export(mafCutoff) export(makePairwiseContrastCol) export(marginalEffects) export(mashCovarianceComponents) @@ -324,7 +308,6 @@ export(nestTupleRanges) export(normalizeVariantId) export(overlapTopLoci) export(panelFilterParam) -export(parseRegion) export(parseVariantId) export(perCsColumns) export(phenotypeCovariates) @@ -334,8 +317,8 @@ export(prsCsWeights) export(pval) export(qcDiagnostics) export(qcInfo) +export(qcOptions) export(qtlAssociationPostprocess) -export(qtlDatasets) export(qtlEnrichment) export(qtlEnrichmentPipeline) export(qtlSumStatsFromBetaMatrix) @@ -350,16 +333,17 @@ export(readSldscFrq) export(readSldscTrait) export(readTwasWeights) export(refVariantInfo) -export(regionToDf) export(regionVcp) export(residualizedGenotypes) export(residualizedPhenotypes) export(resolveWeights) export(retainedMass) +export(ridgeRssWeights) +export(ridgeWeights) +export(sampleSize) export(sanitizeMashData) export(scadRssWeights) export(scadWeights) -export(scaleResiduals) export(scoreFromCs) export(scoreStats) export(screenCtwasRegions) @@ -377,8 +361,6 @@ export(sliceMashData) export(standardizeSldscTrait) export(stratifiedHeritabilityEnrichment) export(studyName) -export(subsetChr) -export(subsetRegion) export(sumStats) export(summaryStatsQc) export(susieAlpha) @@ -399,7 +381,6 @@ export(twasPredict) export(twasWeights) export(twasWeightsCv) export(twasWeightsPipeline) -export(twasWeightsRow) export(twasZ) export(updateMashModelCov) export(varY) @@ -407,7 +388,8 @@ export(variantIds) export(waldTestPval) export(weightStandardized) export(weightsDataType) -export(xvarCutoff) +export(writeBed) +export(writeGwasVcf) export(z) exportClasses(AnnotationMatrix) exportClasses(BoundaryMergeParam) @@ -446,6 +428,7 @@ exportClasses(MrParam) exportClasses(MrmashPriorParam) exportClasses(MultiStudyQtlDataset) exportClasses(PanelFilterParam) +exportClasses(PhenotypeFilterParam) exportClasses(PvalMethodsParam) exportClasses(QtlDataset) exportClasses(QtlEnrichmentParam) @@ -474,23 +457,26 @@ exportMethods("[") exportMethods("[[") exportMethods("[[<-") exportMethods("af<-") +exportMethods("elementMetadata<-") exportMethods("maf<-") -exportMethods("nSamples<-") +exportMethods("sampleSize<-") exportMethods(af) exportMethods(annotCols) exportMethods(annotData) exportMethods(annotationJackknifeCoefs) -exportMethods(as.data.frame) exportMethods(as.list) +exportMethods(as.matrix) exportMethods(baselineAnnotations) exportMethods(bindROWS) exportMethods(blockId) exportMethods(coef) +exportMethods(coerce) exportMethods(colnames) exportMethods(colocBoostOutcomes) exportMethods(colocCredibleSets) exportMethods(colocGenes) exportMethods(colocPairs) +exportMethods(colocPooledVariants) exportMethods(colocVariants) exportMethods(colocboostPipeline) exportMethods(computeLdScores) @@ -505,8 +491,6 @@ exportMethods(cvResult) exportMethods(eigenList) exportMethods(endoapply) exportMethods(estimateH2) -exportMethods(exportToBed) -exportMethods(exportToVcf) exportMethods(fineMappingPipeline) exportMethods(fineMappingResult) exportMethods(frqData) @@ -521,11 +505,8 @@ exportMethods(heritabilityEstimate) exportMethods(heritabilityEstimateSe) exportMethods(heritabilityIntercept) exportMethods(heritabilityInterceptSe) -exportMethods(imissCutoff) exportMethods(inSample) exportMethods(intersectVariants) -exportMethods(keepIndel) -exportMethods(keepVariants) exportMethods(lbf) exportMethods(ldBlocks) exportMethods(ldMatrix) @@ -535,9 +516,7 @@ exportMethods(ldReference) exportMethods(length) exportMethods(localH2Blocks) exportMethods(longForm) -exportMethods(macCutoff) exportMethods(maf) -exportMethods(mafCutoff) exportMethods(marginalEffects) exportMethods(methodFits) exportMethods(methodNames) @@ -554,8 +533,8 @@ exportMethods(pip) exportMethods(pval) exportMethods(qcDiagnostics) exportMethods(qcInfo) +exportMethods(qcOptions) exportMethods(qtlAssociationPostprocess) -exportMethods(qtlDatasets) exportMethods(readAnnotations) exportMethods(readGenotypes) exportMethods(regionVcp) @@ -563,16 +542,15 @@ exportMethods(residualizedGenotypes) exportMethods(residualizedPhenotypes) exportMethods(resolveWeights) exportMethods(retainedMass) -exportMethods(scaleResiduals) +exportMethods(sampleSize) exportMethods(scoreStats) exportMethods(se) exportMethods(show) exportMethods(significantQtls) exportMethods(sldscResults) +exportMethods(sort) exportMethods(stratifiedHeritabilityEnrichment) exportMethods(studyName) -exportMethods(subsetChr) -exportMethods(subsetRegion) exportMethods(sumStats) exportMethods(susieAlpha) exportMethods(susieFit) @@ -580,15 +558,20 @@ exportMethods(testedAnnotations) exportMethods(topLoci) exportMethods(traitNames) exportMethods(traitPosition) +exportMethods(trim) exportMethods(twasWeights) exportMethods(twasWeightsPipeline) +exportMethods(unique) +exportMethods(updateObject) exportMethods(varY) exportMethods(variantIds) exportMethods(weightStandardized) exportMethods(weights) exportMethods(weightsDataType) -exportMethods(xvarCutoff) +exportMethods(writeBed) +exportMethods(writeGwasVcf) exportMethods(z) +importClassesFrom(BiocParallel,BiocParallelParam) importClassesFrom(GenomicRanges,GRanges) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) @@ -602,13 +585,19 @@ importFrom(BiocGenerics, ncol, nrow, path, + sort, + unique, + unstrand, + updateObject, weights, width ) importFrom(BiocParallel, - MulticoreParam, + "bpRNGseed<-", + SerialParam, + bpRNGseed, bplapply, - multicoreWorkers + bpnworkers ) importFrom(Biostrings, DNAStringSet, @@ -625,7 +614,8 @@ importFrom(IRanges, DataFrameList, IRanges, findOverlaps, - overlapsAny + overlapsAny, + trim ) importFrom(MASS,ginv) importFrom(MultiAssayExperiment, @@ -645,8 +635,12 @@ importFrom(Rsamtools, scanTabix, seqnamesTabix ) -importFrom(S4Arrays,extract_array) +importFrom(S4Arrays, + as.matrix, + extract_array +) importFrom(S4Vectors, + "elementMetadata<-", "mcols<-", "metadata<-", DataFrame, @@ -669,6 +663,7 @@ importFrom(archive,archive_read) importFrom(checkmate, assert, assertCharacter, + assertChoice, assertClass, assertCount, assertDataFrame, @@ -709,6 +704,8 @@ importFrom(dplyr, bind_cols, bind_rows, case_when, + coalesce, + count, desc, distinct, everything, @@ -735,6 +732,7 @@ importFrom(metafor,rma) importFrom(methods, "slot<-", as, + coerce, is, new, setClass, @@ -748,6 +746,7 @@ importFrom(methods, importFrom(purrr, compact, detect, + detect_index, discard, exec, imap, @@ -760,7 +759,6 @@ importFrom(purrr, map, map2, map2_dbl, - map2_lgl, map_chr, map_dbl, map_dfr, @@ -769,7 +767,9 @@ importFrom(purrr, partial, pmap, possibly, + pwalk, reduce, + reduce2, set_names, walk, walk2, @@ -788,13 +788,16 @@ importFrom(rlang, abort, arg_match, arg_match0, + call2, caller_arg, cnd_signal, eval_bare, fn_env, fn_fmls, + hash, inform, is_named, + obj_address, try_fetch, warn ) diff --git a/R/AllClasses.R b/R/AllClasses.R index 044f16a6..f3162612 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -44,12 +44,12 @@ setClassUnion( # ----------------------------------------------------------------------------- # Shared parent of the QTL and GWAS summary statistics collections. # Concrete subclasses (QtlSumStats, GwasSumStats) inherit from -# RangedTupleList and share the ldReference / qcInfo slots (the genome build +# RangedTupleList and share the ldReference / qcOptions 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]]. # # z / nSamples / maf / nSnps are -# defined once on SumStatsBase (they only delegate to sumStats); subsetChr / +# defined once on SumStatsBase (they only delegate to sumStats); # varY / sumStats / as.data.frame stay on the concrete subclass because # they rely on the tuple shape (3-tuple QtlSumStats, 1-tuple GwasSumStats). # ============================================================================= @@ -58,36 +58,43 @@ setClassUnion( #' @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{ldReference} / \code{qcInfo} slots, and the genome build in +#' \code{ldReference} / \code{qcOptions} 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 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 +#' @slot ldReference A named list of the LD references the rows were +#' harmonized against and every pipeline reads LD from, each a genotype +#' panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} +#' or an \code{\link{LdMatrix}}. Each distinct reference is stored once, and +#' the \code{ldReference} column of \code{mcols} names the entry each row +#' uses, so rows can sit on different references. Optional: an LD-free row +#' (e.g. for mash, which operates across conditions per variant) has +#' \code{NA} there; 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.). -#' Fine-mapping and TWAS-weights pipelines reject inputs where -#' \code{length(qcInfo(x)) == 0L} -- the slot serves as both the gating -#' flag and the audit trail. +#' @slot qcOptions A \code{list} recording the QC that ran over the +#' collection: the options \code{summaryStatsQc()} was called with and when. +#' Empty \code{list()} on construction. Pipelines that need QC'd summary +#' statistics refuse inputs where \code{length(qcOptions(x)) == 0L}. What +#' QC did to each row is in the \code{qcAudit} column of \code{mcols()}, +#' read as a table with \code{\link{qcInfo}}. #' @export setClass( "SumStatsBase", contains = c("VIRTUAL", "RangedTupleList"), representation( - ldReference = "LdReference_OR_NULL", - qcInfo = "list" - ) + ldReference = "list", + qcOptions = "list" + ), + prototype(ldReference = list()) ) +methods::setValidity("SumStatsBase", function(object) { + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% TRUE +}) + # TRUE when two elements share both their identity tuple AND their span. # Splitting a multi-chromosome study makes the tuple alone non-unique, so the # key is the tuple plus the element's range (spec 4.4: uniqueness is enforced @@ -99,43 +106,54 @@ setClass( } md <- mcols(object) tupleKey <- map(tupleCols, .ssKeyColumn, md = md) - spans <- range(object) - rangeKey <- map_chr(as.list(spans), .ssSpanLabel) + rangeKey <- .keyEmptyElements(object, .rtlRangeKeys(object)) keys <- exec(str_c, !!!c(tupleKey, list(rangeKey)), sep = "|") anyDuplicated(keys) > 0L } +# Span keys with every EMPTY element given a key of its own. An empty element +# has no span to key on -- it is a region QC screened out, or one a filter() +# emptied -- and several of them in one study are the normal outcome of a PIP +# screen over a block-split study, not duplicates. Its block names it when +# the collection carries `blockId`; otherwise its position does, so two empty +# elements only collide when they claim the same block. # @noRd -.ssKeyColumn <- function(cn, md) { - as.character(md[[cn]]) +.keyEmptyElements <- function(object, spanKeys) { + empty <- lengths(object) == 0L + if (!any(empty)) { + return(spanKeys) + } + md <- mcols(object, use.names = FALSE) + block <- if (is_in("blockId", colnames(md))) { + as.character(md$blockId) + } else { + rep(NA_character_, length(object)) + } + emptyKey <- if_else( + is.na(block), + str_c("\u0001row:", seq_along(spanKeys)), + str_c("\u0001block:", block) + ) + if_else(empty, emptyKey, spanKeys) } -# A stable label for one element's span; empty elements collapse to "". # @noRd -.ssSpanLabel <- function(g) { - if (length(g) == 0L) { - return("") - } - str_c( - as.character(seqnames(g))[[1L]], - ":", - min(start(g)), - "-", - max(end(g)) - ) +.ssKeyColumn <- function(cn, md) { + as.character(md[[cn]]) } # Stitch a tuple's elements back into one GRanges, optionally restricted to a -# region. The seqname split means one tuple can own several elements, but the -# accessor contract is still "one GRanges per tuple"; `ranges` lets a caller -# pull just the part they want instead of materialising the whole span. +# window. The seqname split means one tuple can own several elements, but the +# accessor contract is still "one GRanges per tuple". `window` is for the +# pipelines, which score a pair over the span its weights reach; the public +# accessors return the whole tuple and leave narrowing to subsetByOverlaps(). # @noRd -.ssStitchElements <- function(x, idx, ranges = NULL) { +.ssStitchElements <- function(x, idx, window = NULL) { gr <- .rtlGatherElements(x, idx) - if (is.null(ranges)) { + if (is.null(window)) { return(gr) } - win <- .asGRegion(ranges) + win <- .assertRegionGRanges(window, "`window`") onWindowChrom <- is_in( as.character(seqnames(gr)), as.character(seqnames(win)) @@ -176,56 +194,276 @@ setClass( ) } +# The genome build as one string for a show() line. genome() answers per +# SEQLEVEL, so interpolating it directly prints the line once per chromosome +# of a multi-chromosome collection, and not at all for one spanning none. +# @noRd +.showGenomeBuild <- function(x) { + build <- unique(discard(GenomeInfoDb::genome(x), is.na)) + if (length(build) == 0L) { + return("NA") + } + str_flatten(build, ", ") +} + +# ---- The genome build a result carries -------------------------------------- + +# The builds `x` names: a ranged object's seqinfo genome, a QtlDataset's +# experiments', a MultiStudyQtlDataset's studies' and summary statistics', +# a plain list's elements'. An unset (NA) build names nothing, and neither +# does an object without ranges (NULL, an unranged SummarizedExperiment). +# @noRd +.namedBuilds <- function(x) { + builds <- if (is.list(x) && !is.object(x)) { + list_c(map(x, .namedBuilds), ptype = character()) + } else if (is(x, "MultiStudyQtlDataset")) { + c( + list_c(map(as.list(x), .namedBuilds), ptype = character()), + .namedBuilds(sumStats(x)) + ) + } else if (is(x, "MultiAssayExperiment")) { + list_c( + map(as.list(MultiAssayExperiment::experiments(x)), .namedBuilds), + ptype = character() + ) + } else if (.isRangedInput(x)) { + GenomeInfoDb::genome(x) + } else { + character(0) + } + unique(discard(unname(as.character(builds)), is.na)) +} + +# @noRd +.isRangedInput <- function(x) { + is(x, "GenomicRanges") || + is(x, "GRangesList") || + is(x, "RangedSummarizedExperiment") +} + +# The one build `x` names, or NA when it names none -- or several, which a +# collection assembled from mismatched parts can. +# @noRd +.oneBuild <- function(x) { + builds <- .namedBuilds(x) + if (length(builds) == 1L) builds else NA_character_ +} + +# The build a result computed from `inputs` (a list) carries: the one they +# name, or NA when none names one. Inputs naming different builds are +# refused, as GenomeInfoDb refuses to merge ranges whose genomes differ: +# positions on one build do not place variants on another. +# @noRd +.inputsBuild <- function(inputs, caller) { + builds <- unique(list_c(map(inputs, .namedBuilds), ptype = character())) + if (length(builds) > 1L) { + abort(c( + glue( + "{caller}: the inputs name different genome builds ", + "({str_flatten(builds, ', ')})." + ), + i = str_c( + "Positions on one build do not place variants on another: ", + "lift the inputs onto one build, or, when the names only ", + "spell the same build differently, give them one name with ", + "genome(x) <- \"\"." + ) + )) + } + if (length(builds) == 0L) NA_character_ else builds +} + +# `x` with its seqinfo naming `build` for every sequence, or unchanged when +# the build is unknown (NA). +# @noRd +.withGenome <- function(x, build) { + if (is.null(x) || is.na(build)) { + return(x) + } + GenomeInfoDb::`genome<-`(x, value = build) +} + #' @rdname qcInfo #' @examples #' data(qtlSumStatsExample) #' qcInfo(qtlSumStatsExample) #' @export -setMethod("qcInfo", "SumStatsBase", function(x) x@qcInfo) +setMethod("qcInfo", "SumStatsBase", function(x) { + .asViewDataFrame(.ssQcInfoTable(x)) +}) + +#' @rdname qcOptions +#' @examples +#' data(qtlSumStatsExample) +#' qcOptions(qtlSumStatsExample) +#' @export +setMethod("qcOptions", "SumStatsBase", function(x) x@qcOptions) + +# The per-row QC audit as a table: one row per tuple, its identity columns, +# then each scalar count the audits record, a nested count named by its path +# (contentFilters.nDropped). A row a step did not run on is NA there; the +# per-variant tables an audit can also hold are read with qcDiagnostics(). +# @noRd +.ssQcInfoTable <- function(x) { + ids <- intersect( + c("study", "context", "trait", "blockId"), + .tupleColumnNames(x) + ) + base <- as_tibble(set_names(map(ids, .ssIdentityColumn, x = x), ids)) + audits <- mcols(x, use.names = FALSE)$qcAudit + if (is.null(audits)) { + return(base) + } + bind_cols(base, .qcAuditRows(as.list(audits))) +} + +# @noRd +.ssIdentityColumn <- function(cn, x) { + as.character(.tupleColumn(x, cn)) +} + +# One column per scalar count any audit records, NA for the rows without it. +# @noRd +.qcAuditRows <- function(audits) { + flat <- map(audits, .qcAuditScalars) + cols <- unique(list_c(map(flat, names), ptype = character())) + as_tibble( + set_names(map(cols, .qcAuditColumn, flat = flat), cols), + .rows = length(audits) + ) +} + +# @noRd +.qcAuditColumn <- function(col, flat) { + list_c(map(flat, col, .default = NA)) +} + +# One audit's scalar counts as a flat named list, a nested count named by its +# path. Tables and other non-scalar values are left out. +# @noRd +.qcAuditScalars <- function(a, prefix = "") { + if (!is.list(a) || is.data.frame(a) || length(a) == 0L) { + return(list()) + } + list_flatten(unname(map2(a, str_c(prefix, names(a)), .qcAuditLeaf))) +} + +# @noRd +.qcAuditLeaf <- function(v, name) { + if (is.list(v) && !is.data.frame(v)) { + return(.qcAuditScalars(v, str_c(name, "."))) + } + if (is.atomic(v) && length(v) == 1L) { + return(set_names(list(v), name)) + } + list() +} #' @rdname qcDiagnostics #' @examples #' data(qtlSumStatsExample) #' qcDiagnostics(qtlSumStatsExample) #' @export -setMethod("qcDiagnostics", "SumStatsBase", function(x, entry = 1L) { - qc <- x@qcInfo - if (length(qc) == 0L) { - return(NULL) +setMethod( + "qcDiagnostics", + "SumStatsBase", + function(x, studyName = NULL, context = NULL, trait = NULL) { + audits <- mcols(x, use.names = FALSE)$qcAudit + if (is.null(audits)) { + return(NULL) + } + idx <- .ssRowIndexFor(x, studyName, context, trait) + tables <- compact(map(audits[idx], "ldMismatchDiagnostics")) + if (length(tables) == 0L) { + return(NULL) + } + # A GWAS study split across rows checked each row on its own, so its + # tables stack, one row per variant, as sumStats() stitches them. + DataFrame(bind_rows(tables), check.names = FALSE) } - audits <- qc$entryAudit - if (is.null(audits)) { +) + +# Row `i`'s QC audit, or NULL when QC recorded none for it. +# @noRd +.rowQcAudit <- function(x, i) { + audits <- mcols(x, use.names = FALSE)$qcAudit + if (is.null(audits) || i > length(audits)) { return(NULL) } - if (is.null(entry)) { - out <- map(audits, "ldMismatchDiagnostics") - keep <- !map_lgl(out, is.null) - if (!any(keep)) { - return(NULL) + audits[[i]] +} + +# Before each row's QC audit moved into mcols(), a summary-statistics +# collection held its whole QC record in a `qcInfo` slot: the options, and +# under `entryAudit` one audit per row. An object saved then still carries +# that slot as an attribute; it is split into the `qcOptions` slot and the +# `qcAudit` column. An object older still held its genome build in a +# `genome` slot (.ssMigrateGenome()). An object that old needs the updates +# every collection shares too, so the inherited update runs either way. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "SumStatsBase", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message(str_c("updateObject(object = '", class(object)[[1L]], "')")) } - set_names(out[keep], seq_along(audits)[keep]) - } else { - if ( - !is.numeric(entry) || - length(entry) != 1L || - entry < 1L || - entry > length(audits) - ) { - msg <- glue( - "`entry` must be a single integer in 1:{length(audits)}." - ) - abort(msg) + old <- attr(object, "qcInfo", exact = TRUE) + if (!is.null(old)) { + object <- .ssMigrateQcInfo(object, old) } - audits[[as.integer(entry)]]$ldMismatchDiagnostics + methods::callNextMethod( + .ssMigrateGenome(object), + ..., + verbose = verbose + ) } -}) +) + +# Before the genome build moved into seqinfo(), summary statistics held it +# in a `genome` slot; an object saved then still carries it as an +# attribute, and it becomes the build seqinfo() names (none, when the slot +# was left empty). +# @noRd +.ssMigrateGenome <- function(object) { + build <- attr(object, "genome", exact = TRUE) + if (is.null(build)) { + return(object) + } + attr(object, "genome") <- NULL + .withGenome(object, build[1L]) +} + +# @noRd +.ssMigrateQcInfo <- function(object, old) { + attr(object, "qcInfo") <- NULL + attr(object, "qcOptions") <- old[setdiff(names(old), "entryAudit")] + audits <- old$entryAudit + if (length(audits) == 0L) { + return(object) + } + if (length(audits) != length(object)) { + warn(glue( + "updateObject(): the saved QC record holds {length(audits)} row ", + "audit(s) for {length(object)} row(s), so they cannot be matched ", + "to rows and are dropped; qcOptions() keeps the settings." + )) + return(object) + } + `$<-`(object, "qcAudit", S4Vectors::SimpleList(audits)) +} #' @rdname ldReference #' @examples #' data(qtlSumStatsExample) +#' # One entry per distinct reference; each row names its own. #' ldReference(qtlSumStatsExample) +#' qtlSumStatsExample$ldReference #' @export -setMethod("ldReference", "SumStatsBase", function(x) x@ldReference) +setMethod("ldReference", "SumStatsBase", function(x) { + .ldRefsInUse(x) +}) #' @rdname studyName #' @examples @@ -247,53 +485,35 @@ setMethod("studyName", "SumStatsBase", function(x) { setMethod( "z", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mcols(exec(sumStats, x, !!!sel))$Z + trait = trait + ))$Z } ) -#' @rdname nSamples +#' @rdname sampleSize #' @examples #' data(qtlSumStatsExample) -#' nSamples(qtlSumStatsExample) +#' head(sampleSize(qtlSumStatsExample)) #' @export setMethod( - "nSamples", + "sampleSize", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mcols(exec(sumStats, x, !!!sel))$N + trait = trait + ))$N } ) -# pval / coef / se are first-class alongside z / nSamples: they read the +# pval / coef / se are first-class alongside z / sampleSize: they read the # optional P / BETA / SE mcols and return NULL when the entry does not carry # them (DataFrame `$` semantics), so a p-value-primary sumstats (e.g. TensorQTL # cis output) is an equal citizen to a Z-primary GWAS sumstats. @@ -305,22 +525,13 @@ setMethod( setMethod( "pval", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mcols(exec(sumStats, x, !!!sel))$P + trait = trait + ))$P } ) @@ -332,23 +543,13 @@ setMethod( setMethod( "coef", "SumStatsBase", - function( - object, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL, - ... - ) { - sel <- list( - study = studyName, + function(object, studyName = NULL, context = NULL, trait = NULL, ...) { + mcols(sumStats( + object, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mcols(exec(sumStats, object, !!!sel))$BETA + trait = trait + ))$BETA } ) @@ -360,22 +561,13 @@ setMethod( setMethod( "se", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mcols(exec(sumStats, x, !!!sel))$SE + trait = trait + ))$SE } ) @@ -387,22 +579,13 @@ setMethod( setMethod( "maf", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mc <- mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mc <- mcols(exec(sumStats, x, !!!sel)) + trait = trait + )) if (is_in("MAF", colnames(mc))) mc$MAF else NULL } ) @@ -415,22 +598,13 @@ setMethod( setMethod( "af", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + mc <- mcols(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - mc <- mcols(exec(sumStats, x, !!!sel)) + trait = trait + )) if (is_in("AF", colnames(mc))) mc$AF else NULL } ) @@ -439,9 +613,11 @@ setMethod( # Variant-level replacement # ============================================================================= -# The element index the selectors pin. GwasSumStats is keyed by study alone -# and QtlSumStats by the (study, context, trait) tuple; branching here rather -# than adding an internal generic keeps one copy of each replacement body. +# The element indices the selectors pin: every row of the study for a +# GwasSumStats, which is keyed by study alone and split by chromosome or LD +# block, and the one (study, context, trait) row for a QtlSumStats. Branching +# here rather than adding an internal generic keeps one copy of each +# replacement body. # @noRd .ssRowIndexFor <- function(x, studyName, context, trait) { if (methods::is(x, "QtlSumStats")) { @@ -451,29 +627,45 @@ setMethod( .gwasSelectStudy(x, studyName) } -# Write one per-variant column onto the pinned element and put it back. The -# `[[<-` route rebuilds the collection and re-runs validity, so a write that -# would break the identity invariants is refused rather than stored. +# Write one per-variant column onto the pinned elements and put them back. +# `idx` can name several elements -- a GWAS study split by chromosome or LD +# block -- and `values` runs over them in `idx` order, the order sumStats() +# stitches them in. The rebuild re-runs validity, so a write that would break +# the identity invariants is refused rather than stored. # @noRd .ssWriteVariantColumn <- function(x, idx, column, values) { - el <- x[[idx]] - mcols(el)[[column]] <- values - x[[idx]] <- el - x + pieces <- split( + values, + factor(rep(seq_along(idx), lengths(x)[idx]), levels = seq_along(idx)) + ) + elements <- as.list(x) + elements[idx] <- map2( + elements[idx], + pieces, + .ssSetVariantColumn, + column = column + ) + .rtlRebuild(x, elements, seq_along(x)) +} + +# @noRd +.ssSetVariantColumn <- function(el, values, column) { + mcols(el)[[column]] <- unname(values) + el } -# Positional replacement. The vector is taken to be in the element's own -# variant order, so length is the only thing checkable -- and it is checked -# hard: a recycled or truncated frequency vector is silently wrong, which is -# exactly the failure the GRanges form exists to avoid. +# Positional replacement. The vector is taken to be in sumStats()'s variant +# order for the selection, so length is the only thing checkable -- and it is +# checked hard: a recycled or truncated frequency vector is silently wrong, +# which is exactly the failure fillFromReference() exists to avoid. # @noRd .ssVariantColumnPositional <- function(x, idx, column, value) { - n <- length(x[[idx]]) + n <- sum(lengths(x)[idx]) if (length(value) != n) { abort(glue( "{column}: a positional replacement needs one value per variant ", - "({n}); got {length(value)}. Pass a GRanges carrying A1/A2 to ", - "match on (chrom, pos, A1, A2) instead." + "({n}, in sumStats() order); got {length(value)}. Use ", + "fillFromReference() to match on (chrom, pos, A1, A2) instead." )) } .ssWriteVariantColumn(x, idx, column, as.numeric(value)) @@ -493,24 +685,28 @@ setMethod( ) } -# The payload column of a replacement GRanges. A1/A2 are the match key, so -# exactly one other mcols column is the values; requiring that rather than a -# fixed name keeps the caller from having to know the stored column names. +# The values column of a fillFromReference() reference. A1/A2 are the match +# key; the values are the column named like the target when the reference +# has one (a panel GRanges carries several), else its one other column. # @noRd .ssReplacementPayload <- function(value, column) { mc <- mcols(value) nms <- colnames(mc) if (!all(is_in(c("A1", "A2"), nms))) { abort(glue( - "{column}: a GRanges replacement must carry A1 and A2 in ", + "fillFromReference: `reference` must carry A1 and A2 in ", "mcols() so an allele swap can be detected." )) } + if (is_in(column, nms)) { + return(as.numeric(mc[[column]])) + } payload <- setdiff(nms, c("A1", "A2")) if (length(payload) != 1L) { abort(glue( - "{column}: a GRanges replacement must carry exactly one value ", - "column besides A1/A2 (got {length(payload)}", + "fillFromReference: `reference` has no `{column}` column, so ", + "its values must be the one column besides A1/A2 (got ", + "{length(payload)}", "{if (length(payload)) str_c(': ', str_flatten(payload, ', '))", " else ''})." )) @@ -518,21 +714,23 @@ setMethod( as.numeric(mc[[payload]]) } -# Matched replacement. Ids are rebuilt from both sides and paired with -# matchVariants, so a chr-prefix or separator difference does not read as -# no-overlap. A variant the replacement does not name becomes NA -- its value -# is unknown, not unchanged. `directional` says whether an allele swap -# inverts the quantity: AF goes to 1 - AF, while MAF (min(af, 1 - af)) and N -# are swap-invariant, and complementing those would corrupt them. +# Matched fill. Ids are rebuilt from both sides and paired with matchVariants, +# so a chr-prefix or separator difference does not read as no-overlap. A +# variant the reference does not name becomes NA -- its value is unknown, not +# unchanged. `directional` says whether an allele swap inverts the quantity: +# AF goes to 1 - AF, while MAF (min(af, 1 - af)) and N are swap-invariant, +# and complementing those would corrupt them. # @noRd .ssVariantColumnMatched <- function(x, idx, column, value, directional) { vals <- .ssReplacementPayload(value, column) - el <- x[[idx]] + # The whole selection at once, so a variant the reference names is + # "unused" only when it is in none of the study's rows. + el <- .ssStitchElements(x, idx) m <- matchVariants(.ssVariantKeys(el), .ssVariantKeys(value)) if (length(m$idxA) == 0L) { abort(glue( - "{column}: no variant in the replacement matches this entry on ", - "(chrom, pos, A1, A2)." + "fillFromReference: no variant in `reference` matches the ", + "selection on (chrom, pos, A1, A2)." )) } picked <- vals[m$idxB] @@ -541,21 +739,33 @@ setMethod( } out <- rep(NA_real_, length(el)) out[m$idxA] <- picked - unused <- length(value) - length(m$idxB) + .ssWarnUnmatched( + column, + length(value) - length(m$idxB), + length(value), + length(el) - length(m$idxA), + length(el) + ) + .ssWriteVariantColumn(x, idx, column, out) +} + +# The two ways a matched fill falls short, each said with its count: reference +# variants the selection does not hold, and selected variants left NA. +# @noRd +.ssWarnUnmatched <- function(column, unused, nReference, missed, nSelected) { if (unused > 0L) { warn(glue( - "{column}: {unused} of {length(value)} replacement variant(s) ", - "are not in this entry and were ignored." + "fillFromReference({column}): {unused} of {nReference} reference ", + "variant(s) are not in the selection and were ignored." )) } - missed <- length(el) - length(m$idxA) if (missed > 0L) { warn(glue( - "{column}: {missed} of {length(el)} entry variant(s) are not in ", - "the replacement and were set NA." + "fillFromReference({column}): {missed} of {nSelected} selected ", + "variant(s) are not in `reference` and were set NA." )) } - .ssWriteVariantColumn(x, idx, column, out) + invisible(NULL) } # @noRd @@ -568,22 +778,62 @@ setMethod( ) } -# @noRd -.ssReplaceMatched <- function( +#' @title Fill A Per-Variant Column From A Reference +#' @description Fill the \code{AF}, \code{MAF} or \code{N} column of a +#' \code{GwasSumStats} / \code{QtlSumStats} selection from a reference +#' \code{GRanges}, pairing variants on \code{(chrom, pos, A1, A2)} -- the +#' usual case being effect-allele frequencies the source file did not +#' carry, taken from a reference panel. Order does not matter. +#' +#' An allele swap sends \code{AF} to \code{1 - AF}, so a flipped match is +#' complemented; \code{MAF} is \code{min(af, 1 - af)} and \code{N} is a +#' count, both swap-invariant, so neither is. A selected variant the +#' reference does not name is set \code{NA} -- its value is unknown, not +#' unchanged -- with a warning, and so is a reference variant the selection +#' does not hold; no overlap at all is an error. +#' +#' Values already in \code{\link{sumStats}} order are assigned positionally +#' instead, with \code{af(x) <- value} (see +#' \code{\link{variantColumnReplace}}). +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param reference A \code{GRanges} carrying \code{A1} and \code{A2} in +#' \code{mcols()} plus the values: a column named like \code{column}, or +#' else its one column besides \code{A1}/\code{A2}. +#' @param column Which column to fill: \code{"AF"} (default), \code{"MAF"} or +#' \code{"N"}. +#' @param studyName,context,trait Selectors pinning one study (every row of a +#' GWAS study) or one \code{QtlSumStats} entry; \code{context} and +#' \code{trait} are \code{QtlSumStats}-only. +#' @return \code{x}, with the selection's column filled. +#' @examples +#' data(qtlSumStatsExample) +#' ref <- sumStats(qtlSumStatsExample) +#' S4Vectors::mcols(ref) <- S4Vectors::DataFrame( +#' A1 = ref$A1, +#' A2 = ref$A2, +#' AF = runif(length(ref)) +#' ) +#' x <- fillFromReference(qtlSumStatsExample, ref, "AF") +#' head(af(x)) +#' @importFrom checkmate assertClass +#' @export +fillFromReference <- function( x, - column, - value, - directional, - studyName, - context, - trait + reference, + column = c("AF", "MAF", "N"), + studyName = NULL, + context = NULL, + trait = NULL ) { + assertClass(x, "SumStatsBase") + assertClass(reference, "GRanges") + column <- arg_match(column) .ssVariantColumnMatched( x, .ssRowIndexFor(x, studyName, context, trait), column, - value, - directional + reference, + directional = identical(column, "AF") ) } @@ -597,24 +847,6 @@ setReplaceMethod( } ) -#' @rdname variantColumnReplace -#' @export -setReplaceMethod( - "af", - signature(x = "SumStatsBase", value = "GRanges"), - function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { - .ssReplaceMatched( - x, - "AF", - value, - directional = TRUE, - studyName, - context, - trait - ) - } -) - #' @rdname variantColumnReplace #' @export setReplaceMethod( @@ -628,49 +860,13 @@ setReplaceMethod( #' @rdname variantColumnReplace #' @export setReplaceMethod( - "maf", - signature(x = "SumStatsBase", value = "GRanges"), - function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { - .ssReplaceMatched( - x, - "MAF", - value, - directional = FALSE, - studyName, - context, - trait - ) - } -) - -#' @rdname variantColumnReplace -#' @export -setReplaceMethod( - "nSamples", + "sampleSize", signature(x = "SumStatsBase", value = "numeric"), function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { .ssReplacePositional(x, "N", value, studyName, context, trait) } ) -#' @rdname variantColumnReplace -#' @export -setReplaceMethod( - "nSamples", - signature(x = "SumStatsBase", value = "GRanges"), - function(x, studyName = NULL, context = NULL, trait = NULL, ..., value) { - .ssReplaceMatched( - x, - "N", - value, - directional = FALSE, - studyName, - context, - trait - ) - } -) - #' @rdname nSnps #' @examples #' data(qtlSumStatsExample) @@ -679,22 +875,13 @@ setReplaceMethod( setMethod( "nSnps", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { - sel <- list( - study = studyName, + function(x, studyName = NULL, context = NULL, trait = NULL) { + length(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - length(exec(sumStats, x, !!!sel)) + trait = trait + )) } ) @@ -712,22 +899,45 @@ 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{ldReference} slot. +#' carry a \code{DFrame} of per-fit rows and an \code{ldReference} slot +#' listing the LD references those fits used. #' 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 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. +#' @slot ldReference A named list of the LD references the fits were +#' computed against, each a genotype panel, a \code{GenotypeMixture} or an +#' \code{LdMatrix}, stored once apiece; the \code{ldReference} column of +#' \code{mcols} names the entry each row used (\code{NA} for a fit derived +#' from individual-level data). Used downstream to check that the rows a +#' pipeline combines share an LD reference. +#' @section Narrowed rows: Each row records in its \code{fitVariants} column +#' the ids of the variants its fit was made with (none for a row without a +#' fit). A row narrowed since -- by \code{endoapply()} or \code{[[<-} -- +#' keeps its fit as it was, so every reader of the fit warns, with +#' condition class \code{pecotmrFitCoverage}, when a row holds fewer +#' variants than its fit describes. The readers are the accessors +#' (\code{susieFit()}, \code{lbf()}, \code{cvResult()}, +#' \code{credibleSetSummary()} and the fSuSiE views), +#' \code{computeCsCorrelation()}, \code{susieResult()}, +#' \code{extractCsInfo()}, \code{extractTopPipInfo()}, +#' \code{writeGwasVcf()}, and the pipelines that score the fits: +#' \code{colocPipeline(adjustPips = FALSE)}, \code{qtlEnrichmentPipeline()} +#' and \code{twasWeightsPipeline()}. Values held per variant, such as +#' \code{topLoci()}, are narrowed with the row and do not warn. Nothing is +#' rescaled: \code{\link{intersectVariants}} restricts a fit explicitly, as +#' \code{colocPipeline()} does by default. #' @export setClass( "FineMappingResultBase", contains = c("VIRTUAL", "RangedTupleList"), - representation(ldReference = "LdReference_OR_NULL") + representation(ldReference = "list"), + prototype(ldReference = list()) ) +methods::setValidity("FineMappingResultBase", function(object) { + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) %||% TRUE +}) + #' @rdname studyName #' @export setMethod("studyName", "FineMappingResultBase", function(x) { @@ -736,7 +946,9 @@ setMethod("studyName", "FineMappingResultBase", function(x) { #' @rdname ldReference #' @export -setMethod("ldReference", "FineMappingResultBase", function(x) x@ldReference) +setMethod("ldReference", "FineMappingResultBase", function(x) { + .ldRefsInUse(x) +}) #' @rdname methodNames #' @examples @@ -747,7 +959,6 @@ setMethod("methodNames", "FineMappingResultBase", function(x) { unique(as.character(x$method)) }) - #' @noRd setMethod( "adjustPips", @@ -757,8 +968,8 @@ setMethod( return(x) } # Entries sharing no variant with `keepVariants` have nothing to - # renormalize, so they are DROPPED -- matching subsetRegion's rule that - # elements trimming to zero variants go away. Every other failure (a + # renormalize, so they are DROPPED, leaving no entry with zero + # variants. Every other failure (a # fit that cannot be honestly subset, a slot whose width disagrees with # the variant count) PROPAGATES: silently leaving those entries # unadjusted mixes adjusted and unadjusted fits in one object, which is @@ -806,11 +1017,16 @@ setMethod( "susieFit", value = S4Vectors::SimpleList(map(entries, susieFit)) ) - `[[<-`( + withCv <- `[[<-`( withFit, "cvResult", value = S4Vectors::SimpleList(map(entries, cvResult)) ) + `[[<-`( + withCv, + "fitVariants", + value = IRanges::CharacterList(map(entries, .fmRowFitVariants)) + ) } # Rebuild a fine-mapping collection from adjusted entries, keeping every @@ -818,10 +1034,11 @@ setMethod( # @noRd .fmrFromEntries <- function(x, entries) { grl <- `mcols<-`( - GenomicRanges::GRangesList(map(entries, variants)), + .rtlBindElements(map(entries, variants)), value = .withEntryPayload(mcols(x, use.names = FALSE), entries) ) - new(class(x), grl, ldReference = .asLdRef(ldReference(x))) + # The rows keep their keys in mcols, so the references go across as is. + new(class(x), grl, ldReference = x@ldReference) } # TRUE when an entry shares at least one variant with `keepVariants`, matched @@ -903,7 +1120,17 @@ setMethod( #' @rdname retainedMass #' @export -setMethod("retainedMass", "FineMappingResultBase", function(x) { +setMethod( + "retainedMass", + "FineMappingResultBase", + function(x) { + .asViewDataFrame(.rcMassTable(x = x)) + } +) + +# retainedMass() as a tibble. +# @noRd +.rcMassTable <- function(x) { if (nrow(x) == 0L) { return(.rcEmptyMass(x)) } @@ -912,7 +1139,7 @@ setMethod("retainedMass", "FineMappingResultBase", function(x) { return(.rcEmptyMass(x)) } bind_rows(parts) -}) +} # The zero-row result, carrying the SAME identity columns the populated one # would. Returning a bare (effect, retainedMass, nVariants) tibble instead @@ -991,9 +1218,10 @@ setMethod("retainedMass", "FineMappingResultBase", function(x) { as.character(md[[cn]])[[i]] } -# Select the single FineMappingRow addressed by a (tuple / region) key. Each -# concrete subclass implements this with its own row selector; the delegating -# accessors below then live once on the base and route through it. +# Select the single FineMappingRow addressed by a tuple key or a GWAS block's +# `blockId`. Each concrete subclass +# implements this with its own row selector; the delegating accessors below +# then live once on the base and route through it. setGeneric(".fmrSelectEntry", function(x, ...) { standardGeneric(".fmrSelectEntry") }) @@ -1009,7 +1237,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, + blockId = NULL, coverage = 0.95, minPurity = NULL ) { @@ -1018,27 +1246,32 @@ setMethod( # partial selectors -> aggregate every matching entry's credible sets, # prefixed with the row identity (study/context/trait/blockId/method). # `minPurity` is an independent CS-quality filter, orthogonal to - # coverage. - .fmrAggregateView( + # coverage. Ranged either way, so it narrows with subsetByOverlaps(). + tbl <- .fmrAggregateView( x, studyName = studyName, context = context, trait = trait, method = method, - region = region, + blockId = blockId, perEntry = .fmrRowCs, viewArgs = list( coverage = coverage, minPurity = minPurity ) ) + .withGenome(.variantTableGRanges(tbl), .oneBuild(x)) } ) #' @rdname lbf #' @export setMethod("lbf", "FineMappingResultBase", function(x) { - .fmrAggregateView(x, perEntry = .fmrRowLbf) + .fitCoverageCheckedRows(x, "lbf()") + .withGenome( + .variantTableGRanges(.fmrAggregateView(x, perEntry = .fmrRowLbf)), + .oneBuild(x) + ) }) #' @rdname credibleSetSummary @@ -1047,23 +1280,50 @@ setMethod( "credibleSetSummary", "FineMappingResultBase", function(x, coverage = 0.95) { - .fmrAggregateView( - x, - perEntry = .fmrRowCredibleSetSummary, - viewArgs = list(coverage = coverage) - ) + .fitCoverageCheckedRows(x, "credibleSetSummary()") + .asViewDataFrame(.fmrCredibleSetSummaryTable( + x = x, + coverage = coverage + )) } ) +# credibleSetSummary() as a tibble. +# @noRd +.fmrCredibleSetSummaryTable <- function(x, coverage = 0.95) { + .fmrAggregateView( + x, + perEntry = .fmrRowCredibleSetSummary, + viewArgs = list(coverage = coverage) + ) +} + #' @rdname fsusieCredibleBand #' @export setMethod("fsusieCredibleBand", "FineMappingResultBase", function(x) { - .fmrAggregateView(x, perEntry = .fmrRowFsusieCredibleBand) + .fitCoverageCheckedRows(x, "fsusieCredibleBand()") + .withGenome( + .bandTableGRanges( + .fmrAggregateView(x, perEntry = .fmrRowFsusieCredibleBand) + ), + .oneBuild(x) + ) }) #' @rdname fsusieTraitEffects #' @export -setMethod("fsusieTraitEffects", "FineMappingResultBase", function(x) { +setMethod( + "fsusieTraitEffects", + "FineMappingResultBase", + function(x) { + .fitCoverageCheckedRows(x, "fsusieTraitEffects()") + .asViewDataFrame(.fsusieTraitEffectsTable(x = x)) + } +) + +# fsusieTraitEffects() as a tibble, for the writers. +# @noRd +.fsusieTraitEffectsTable <- function(x) { # Not .fmrAggregateView(): the per-entry payload carries only the fit, and # this view also needs the row's `jointTraits` column for the trait names. meta <- .fmrRowMetadata(x) @@ -1077,17 +1337,18 @@ setMethod("fsusieTraitEffects", "FineMappingResultBase", function(x) { return(bind_cols(slice(meta, integer(0)), .emptyTraitEffects())) } .rbindAligned(parts) -}) +} #' @rdname fsusieAffectedRegions #' @export setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x) { + .fitCoverageCheckedRows(x, "fsusieAffectedRegions()") perRow <- map(seq_len(nrow(x)), .fsusieEntryAffectedRegions, x = x) grs <- perRow[lengths(perRow) > 0L] if (length(grs) == 0L) { return(GenomicRanges::GRanges()) } - exec(c, !!!grs) + .withGenome(exec(c, !!!grs), .oneBuild(x)) }) #' @rdname topLoci @@ -1102,71 +1363,48 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - minPurity = NULL, - raw = FALSE + blockId = NULL, + minPurity = NULL ) { - # The five selectors travel together to both branches, so they are - # named once and spliced rather than relisted twice. sel <- list( - study = studyName, + studyName = studyName, context = context, trait = trait, method = method, - region = region + blockId = blockId ) - # raw = TRUE hands back the stored canonical table verbatim, which is - # a data.frame by definition -- there is no posterior projection to - # put on a range. - if (isTRUE(raw)) { - return(exec(.fmrbTopLociTable, x, !!!sel, list(raw = TRUE))) - } # The per-variant table first -- bare when the selectors pin one # entry, else the matching rows' tables stacked with row-identity # columns -- then one conversion to ranges. Converting last is what # lets the aggregate form be a GRanges too: the identity columns just # become mcols, where the old type = "GRanges" branch had to refuse # anything but a single pinned entry. - tbl <- exec( - .fmrbTopLociTable, + tbl <- .fmrbTopLociTable( x, - !!!sel, + sel, list(signalCutoff = signalCutoff, minPurity = minPurity) ) - .fmeTopLociGRanges(tbl) + .withGenome(.variantTableGRanges(tbl), .oneBuild(x)) } ) - -# The per-variant top-loci table: the stored table verbatim (raw) or the -# projected posterior view, selected by `viewArgs`. Both stack with -# row-identity columns when the selectors match more than one entry. The +# The per-variant top-loci table: the projected posterior view `viewArgs` +# configures, stacked with row-identity columns when the selectors match more +# than one entry. The # caller converts to ranges; this stays a table so the aggregate form can be # stacked before conversion. # @noRd -.fmrbTopLociTable <- function( - x, - studyName, - context, - trait, - method, - region, - viewArgs -) { - .fmrAggregateView( +.fmrbTopLociTable <- function(x, selectors, viewArgs) { + exec( + .fmrAggregateView, x, - studyName = studyName, - context = context, - trait = trait, - method = method, - region = region, + !!!selectors, perEntry = .fmrRowTopLoci, viewArgs = viewArgs ) } -# raw = TRUE hands back the stored canonical table verbatim, so the -# posterior-view projection does not apply -- and marginal effects are -# not a posterior view, so they stay a table rather than ranges. +# Marginal effects are per variant, so they come back ranged like the +# posterior view. #' @rdname marginalEffects #' @export setMethod( @@ -1174,37 +1412,82 @@ setMethod( "FineMappingResultBase", function( x, - maxPval = NULL, studyName = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { # Selectors pinning one entry -> that entry's bare marginal table; no / # partial selectors -> aggregate every matching entry's marginals, # prefixed with the row identity (study/context/trait/blockId/method). - .fmrAggregateView( + tbl <- .fmrAggregateView( x, studyName = studyName, context = context, trait = trait, method = method, - region = region, - perEntry = .fmrRowMarginalEffects, - viewArgs = list(maxPval = maxPval) + blockId = blockId, + perEntry = .fmrRowMarginalEffects ) + .withGenome(.variantTableGRanges(tbl), .oneBuild(x)) } ) -#' @rdname genomicRegion -#' @examples -#' data(qtlFineMappingExample) -#' genomicRegion(qtlFineMappingExample) +# Before rows recorded the variants their fits were made with, a collection +# had no `fitVariants` column. A fine-mapping fit names its own variants, so +# each row's are read off it; a row whose fit names none (a +# cross-validation-only row, or an unnamed fit) records what it holds, and a +# row with no fit records none. The inherited update runs either way, for +# the updates every collection shares. +#' @rdname updateObject-methods #' @export -setMethod("genomicRegion", "FineMappingResultBase", function(x) { - .getRegionColumn(x) -}) +setMethod( + "updateObject", + "FineMappingResultBase", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message(str_c("updateObject(object = '", class(object)[[1L]], "')")) + } + if (!is_in("fitVariants", .tupleColumnNames(object))) { + fv <- map(seq_along(object), .fmrBackfillFitVariants, x = object) + object <- `$<-`(object, "fitVariants", IRanges::CharacterList(fv)) + } + methods::callNextMethod(object, ..., verbose = verbose) + } +) + +# @noRd +.fmrBackfillFitVariants <- function(i, x) { + md <- mcols(x, use.names = FALSE) + fit <- md$susieFit[[i]] + if (length(fit) == 0L && is.null(md$cvResult[[i]])) { + return(character(0)) + } + named <- .fitNamedVariants(fit) + if (length(named) > 0L) { + return(normalizeVariantId(named)) + } + .grVariantIds(x[[i]]) +} + +# The variant names a fine-mapping fit carries: its PIPs' names, else the +# columns of its effect matrices (SuSiE, mvSuSiE) or of csd_X (fSuSiE); none +# for an unnamed fit. A null_weight fit gives its effect matrices one more +# column, which susieR names "null"; that is no variant. +# @noRd +.fitNamedVariants <- function(fit) { + if (!is.list(fit)) { + return(character(0)) + } + named <- as.character( + names(fit[["pip"]]) %||% + colnames(fit[["alpha"]]) %||% + colnames(fit[["lbf_variable"]]) %||% + names(fit[["csd_X"]]) + ) + named[named != "null"] +} #' @rdname traitPosition #' @examples @@ -1226,16 +1509,17 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { - .fmrPartsSusieFit(.fmrSelectEntry( + parts <- .fmrSelectEntry( x, studyName = studyName, context = context, trait = trait, method = method, - region = region - )) + blockId = blockId + ) + .fmrPartsSusieFit(.fitCoverageChecked(parts, "susieFit()")) } ) @@ -1250,7 +1534,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { # The per-variant weight of the row a selector pins. Defined on the # collection because that is what fineMappingResult() now @@ -1258,14 +1542,14 @@ setMethod( # # The selectors are named, not absorbed by `...`: .fmrSelectEntry is the # only consumer, and each concrete class refuses the ones it does not - # index by (a QtlFineMappingResult has no `region` axis). + # index by (a QtlFineMappingResult has no `blockId` axis). .fmrRowResolveWeights(.fmrSelectEntry( x, studyName = studyName, context = context, trait = trait, method = method, - region = region + blockId = blockId )) } ) @@ -1281,7 +1565,7 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { .fmrPartsVariantIds(.fmrSelectEntry( x, @@ -1289,7 +1573,7 @@ setMethod( context = context, trait = trait, method = method, - region = region + blockId = blockId )) } ) @@ -1299,44 +1583,18 @@ setMethod( setMethod( "variantIds", "SumStatsBase", - function( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL - ) { + function(x, studyName = NULL, context = NULL, trait = NULL) { # One method covers GwasSumStats and QtlSumStats. The selectors are the - # union: GwasSumStats reads only `study` / `ranges` and refuses the + # union: GwasSumStats reads only `studyName` and refuses the # QtlSumStats-only ones rather than accepting and ignoring them. # # Rendered with the same .grVariantIds() the row classes use, so an id # means the same string whichever object produced it. - sel <- list( - study = studyName, + .grVariantIds(sumStats( + x, + studyName = studyName, context = context, - trait = trait, - annotateSignificance = annotateSignificance, - ranges = ranges - ) - .grVariantIds(exec(sumStats, x, !!!sel)) + trait = trait + )) } ) - -#' @rdname subsetChr -#' @export -setMethod("subsetChr", "SumStatsBase", function(x, chr) { - # The whole-seqname special case of subsetRegion(): one verb, one set of - # semantics. Elements on other chromosomes are dropped rather than kept as - # empties, which is what the seqname split makes natural anyway -- after - # splitting, an element belongs to exactly one chromosome. - chrName <- withChrPrefix(chr) - subsetRegion( - x, - GenomicRanges::GRanges( - chrName, - IRanges::IRanges(1L, .Machine$integer.max) - ) - ) -}) diff --git a/R/AllGenerics.R b/R/AllGenerics.R index deb1db41..e1ab2277 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -134,7 +134,7 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' \code{plink2Prefix} for a triplet stem, \code{bed}/\code{bim}/\code{fam} #' or \code{pgen}/\code{pvar}/\code{psam} for explicit triplet paths, #' \code{genoMeta} for a one-file-per-chromosome panel (optionally narrowed -#' with \code{chroms}), or \code{ldMeta} plus \code{region} to resolve a +#' with \code{chroms}), or \code{ldMeta} plus \code{block} 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.gz}, \code{.vcf.bgz}, \code{.gds} or \code{.bgen}). Omit it @@ -180,14 +180,15 @@ setGeneric("computeLdScores", function(ldRef, annotations = NULL, ...) { #' 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}. +#' \code{genoMeta} shards whose chromosome is listed are read; a label may +#' be in any style (\code{"chr1"} or \code{"1"}). Meaningful only with +#' \code{genoMeta}. #' @param ldMeta Path to an LD-meta TSV (columns \code{chrom}, \code{start}, -#' \code{end}, \code{path}). Requires \code{region}: the row covering it is +#' \code{end}, \code{path}). Requires \code{block}: the row covering it is #' resolved and the file it names is read with the matching backend. -#' @param region Region to resolve out of \code{ldMeta}: a -#' \code{"chr:start-end"} string, or a one-row data.frame with -#' \code{chrom}, \code{start}, \code{end}. +#' @param block The \code{GRanges} window whose LD block to read out of +#' \code{ldMeta}. It chooses a file rather than filtering records: the +#' panel is the whole LD block that covers it. #' @param vcfArgs Optional named list of arguments forwarded to #' \code{VariantAnnotation::readVcf} when a VCF's records are read (its #' genotypes are read a block at a time, as they are needed). @@ -214,7 +215,7 @@ setGeneric("readGenotypes", function(path, format = NULL, ...) { #' @title Read Annotations #' @description Read genomic annotations from files (BED, BigWig, S-LDSC .annot #' format, or GRanges objects) and create an AnnotationMatrix. -#' @param paths Named character vector of file paths, or a named list of GRanges +#' @param path Named character vector of file paths, or a named list of GRanges #' objects. Names become annotation names. #' @param snpRanges A \code{GRanges} object defining SNP positions. #' @param annotationMeta A \code{data.frame} with annotation metadata (name, @@ -231,7 +232,7 @@ setGeneric("readGenotypes", function(path, format = NULL, ...) { #' @export setGeneric( "readAnnotations", - function(paths, snpRanges, annotationMeta = NULL, genome = "hg19", ...) { + function(path, snpRanges, annotationMeta = NULL, genome = "hg19", ...) { standardGeneric("readAnnotations") } ) @@ -289,21 +290,36 @@ setGeneric("scoreStats", function(object) standardGeneric("scoreStats")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of z-scores. #' @export 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, 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. +#' @title Get the Number of Reference Samples +#' @description The number of samples an LD reference was built from: the +#' samples carried by a \code{GenotypeHandle}, or the panel size an +#' \code{\link{LdMatrix}} records. The per-variant sample size of summary +#' statistics is \code{\link{sampleSize}}. +#' @param x An \code{LdMatrix} or \code{GenotypeHandle} object. +#' @param ... Class-specific selection arguments. +#' @return An integer of length 1 (\code{NA} when an \code{LdMatrix} 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. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:8] +#' nSamples(LdMatrix(cor(X), nSamples = nrow(X))) +#' @export +setGeneric("nSamples", function(x, ...) standardGeneric("nSamples")) + +#' @title Get Per-Variant Sample Sizes +#' @description Extract the per-variant sample-size vector (the \code{N} +#' column) of a \code{GwasSumStats} or \code{QtlSumStats} entry, selected +#' by its identity tuple. Part of the summary-statistic column set alongside +#' \code{\link{z}}, \code{\link{se}} and \code{\link{pval}}; replace it +#' with \code{\link[=variantColumnReplace]{sampleSize<-}}. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -311,18 +327,10 @@ setGeneric("z", function(x, ...) standardGeneric("z")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @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} 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. +#' @return Numeric vector of per-variant sample sizes, or \code{NULL} when the +#' entry carries none. #' @export -setGeneric("nSamples", function(x, ...) standardGeneric("nSamples")) +setGeneric("sampleSize", function(x, ...) standardGeneric("sampleSize")) #' @title Get Association P-values #' @description Extract the association p-value vector from a @@ -337,10 +345,6 @@ setGeneric("nSamples", function(x, ...) standardGeneric("nSamples")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of p-values, or \code{NULL} if not available. #' @export setGeneric("pval", function(x, ...) standardGeneric("pval")) @@ -360,10 +364,6 @@ setGeneric("pval", function(x, ...) standardGeneric("pval")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of effect sizes, or \code{NULL} if not available. #' @importFrom stats coef #' @rdname coef-methods @@ -381,36 +381,24 @@ setGeneric("coef") #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Numeric vector of standard errors, or \code{NULL} if not available. #' @export setGeneric("se", function(x, ...) standardGeneric("se")) #' @title Get Minor Allele Frequencies -#' @description Extract MAF vector from a GwasSumStats object. -#' @param x A \code{GwasSumStats} or \code{QtlDataset} object. -#' @param ... Class-specific selection arguments (e.g., \code{region}, -#' \code{cisWindow} for \code{QtlDataset}). +#' @description Extract the minor-allele-frequency vector from one entry of +#' a summary-statistic collection, or from a \code{QtlDataset} over the +#' whole dataset (narrow it first, with \code{x[i, j, ]}, to read part of +#' it). +#' @param x A \code{GwasSumStats}, \code{QtlSumStats} or \code{QtlDataset} +#' object. +#' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. #' @param context Character (length 1) or \code{NULL}. Restrict the selection to #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. -#' @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 cisWindow Integer or \code{NULL}. Half-width (bp) of the cis window -#' 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. #' @return Numeric vector of MAFs, or NULL if not available. #' @export setGeneric("maf", function(x, ...) standardGeneric("maf")) @@ -419,30 +407,22 @@ setGeneric("maf", function(x, ...) standardGeneric("maf")) #' @description Supply or overwrite one per-variant column of a #' \code{GwasSumStats} / \code{QtlSumStats} entry after construction -- #' the usual case being an effect-allele frequency the source file did not -#' carry. Dispatch is on \code{value}: -#' \describe{ -#' \item{\code{numeric}}{positional: the vector is in the entry's own -#' variant order and must have exactly one value per variant. Length is -#' checked hard, because a recycled or truncated vector is otherwise -#' silently wrong.} -#' \item{\code{GRanges}}{matched: paired to the entry on -#' \code{(chrom, pos, A1, A2)} via \code{matchVariants}, so ordering -#' does not matter. \code{A1}/\code{A2} are \strong{required} in -#' \code{mcols()} so an allele swap can be detected, and exactly one -#' other \code{mcols} column carries the values. Entry variants the -#' replacement does not name are set \code{NA}.} -#' } -#' An allele swap sends \code{af} to \code{1 - af}, so \code{af<-} -#' complements a flipped match. \code{maf} is \code{min(af, 1 - af)} and -#' \code{nSamples} is a count, both swap-invariant, so neither is -#' complemented. +#' carry. The value is positional: a vector in \code{\link{sumStats}} +#' order for the selection -- a GWAS study split across rows is stitched, +#' as \code{sumStats()} returns it -- with exactly one value per variant. +#' Length is checked hard, because a recycled or truncated vector is +#' otherwise silently wrong. To take the values from a reference keyed by +#' variant instead, matched on \code{(chrom, pos, A1, A2)} and oriented to +#' the entry's alleles, use \code{\link{fillFromReference}}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. -#' @param studyName,context,trait Selectors pinning one entry; \code{context} -#' and \code{trait} are \code{QtlSumStats}-only. +#' @param studyName,context,trait Selectors pinning one study (every row of a +#' GWAS study) or one \code{QtlSumStats} entry; \code{context} and +#' \code{trait} are \code{QtlSumStats}-only. #' @param ... Unused. -#' @param value A \code{numeric} vector (positional) or a \code{GRanges} -#' carrying \code{A1}/\code{A2} plus one value column (matched). -#' @return The object, with that entry's column replaced. +#' @param value A \code{numeric} vector, one value per variant in +#' \code{sumStats()} order. +#' @return The object, with the selection's column replaced. \code{sampleSize<-} +#' writes the per-variant \code{N}. #' @examples #' data(qtlSumStatsExample) #' x <- qtlSumStatsExample @@ -459,8 +439,8 @@ setGeneric("maf<-", function(x, ..., value) standardGeneric("maf<-")) #' @rdname variantColumnReplace #' @export -setGeneric("nSamples<-", function(x, ..., value) { - standardGeneric("nSamples<-") +setGeneric("sampleSize<-", function(x, ..., value) { + standardGeneric("sampleSize<-") }) #' @title Get Effect-Allele Frequencies @@ -473,30 +453,17 @@ setGeneric("nSamples<-", function(x, ..., value) { #' \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. +#' for supplying one afterwards. A \code{QtlDataset} answers over the whole +#' dataset; narrow it first, with \code{x[i, j, ]}, to read part of it. #' @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 -#' to select; \code{NULL} matches all traits in the dataset. +#' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. #' @param context Character (length 1) or \code{NULL}. Restrict the selection to #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. -#' @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 cisWindow Integer or \code{NULL}. Half-width (bp) of the cis window -#' 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. #' @return Named numeric vector of effect-allele frequencies (names are variant #' IDs), or an empty vector when no variants are selected. #' @examples @@ -518,10 +485,6 @@ setGeneric("af", function(x, ...) standardGeneric("af")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. #' @return Integer. #' @export setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) @@ -594,23 +557,12 @@ setGeneric("significantQtls", function(x, ...) { standardGeneric("significantQtls") }) -#' @title Subset by Chromosome -#' @description Extract a chromosome-specific subset of a GwasSumStats object. -#' @param x A \code{GwasSumStats} object. -#' @param chr Character, chromosome name (e.g., "1", "chr1"). -#' @return A \code{GwasSumStats} object. -#' @examples -#' data(gwasSumStatsS4Example) -#' subsetChr(gwasSumStatsS4Example, "chr22") -#' @export -setGeneric("subsetChr", function(x, chr) standardGeneric("subsetChr")) - #' @title Reconcile Two Collections to Their Shared Variants #' @description Restrict two fine-mapping collections to the variants they have #' in common, renormalizing each retained single-effect posterior over the #' variants that survive. -#' @details \code{subsetRegion()} restricts ONE object to a window; this -#' intersects TWO objects against each other. Coloc needs it symmetric -- +#' @details This intersects two objects against each other. Coloc needs it +#' symmetric -- #' both sides must be scored on the same variant set -- while TWAS, MR and #' cTWAS need it one-sided, adjusting the QTL side to the GWAS variant set #' and leaving the GWAS side alone. @@ -660,7 +612,7 @@ setGeneric("intersectVariants", function(x, y, oneSided = FALSE, ...) { #' null. An explicit diagnostic is the only thing that surfaces this. #' @param x A fine-mapping collection. #' @param ... Additional arguments passed to methods. -#' @return A \code{data.frame}, one row per (element, effect), with the +#' @return A \code{DataFrame}, one row per (element, effect), with the #' element's identity columns, the effect index, and its retained mass. #' @examples #' data(qtlFineMappingExample) @@ -674,43 +626,6 @@ setGeneric("retainedMass", function(x, ...) { standardGeneric("retainedMass") }) -#' @title Restrict a Collection to a Region -#' @description Narrow a \code{RangedTupleList} collection to an analysis -#' window: elements that do not overlap it are dropped, and the survivors are -#' trimmed to the overlapping variants. Elements that trim to zero variants -#' are dropped too. -#' @details This is deliberately a new verb rather than a redefinition of a -#' Bioconductor generic, because three genuinely different operations are in -#' play and all three are useful: -#' \describe{ -#' \item{\code{subsetByOverlaps(x, win)}}{selects elements, keeps them -#' whole.} -#' \item{\code{restrict(x, start, end)}}{trims elements, keeps empty ones.} -#' \item{\code{subsetRegion(x, win)}}{selects AND trims AND drops empties.} -#' } -#' \code{subsetChr()} is the whole-seqname special case of this verb. -#' @param x A \code{RangedTupleList} collection. -#' @param region A \code{GRanges}, a \code{"chr:start-end"} string, or a -#' one-row \code{data.frame} with \code{chrom} / \code{start} / \code{end}. -#' @param ... Additional arguments passed to methods. Fine-mapping collections -#' accept \code{adjust} to renormalize PIPs over the retained variants. -#' @return An object of the same class as \code{x}, with the collection-level -#' slots carried over and \code{mcols} narrowed to the surviving elements. -#' @examples -#' data(qtlSumStatsMulticontextExample) -#' mc <- qtlSumStatsMulticontextExample -#' sum(lengths(mc)) -#' # Every element is narrowed to the window; the collection keeps its shape, -#' # so an element with nothing left stays as an empty one rather than a -#' # dropped row. -#' sub <- subsetRegion(mc, "chr22:14560203-15000000") -#' sum(lengths(sub)) -#' nrow(sub) -#' @export -setGeneric("subsetRegion", function(x, region, ...) { - standardGeneric("subsetRegion") -}) - #' @title Get Phenotype Variance #' @description Extract phenotype variance from a \code{GwasSumStats} or #' \code{QtlSumStats} entry, selected by its identity tuple. Returns @@ -751,11 +666,6 @@ setGeneric("varY", function(x, ...) standardGeneric("varY")) #' this context; \code{NULL} matches all contexts. #' @param trait Character (length 1) or \code{NULL}. Restrict the selection to #' this trait; \code{NULL} matches all traits. -#' @param ranges A \code{GRanges} or \code{NULL} (default). A selected tuple can -#' own several elements -- one per chromosome, since a multi-seqname entry is -#' split at construction -- and they are stitched back into a single -#' \code{GRanges}. Pass \code{ranges} to pull only the variants overlapping a -#' region instead of the whole span; \code{NULL} returns everything. #' @return A \code{GRanges}, a \code{QtlSumStats}, or \code{NULL}. #' @examples #' data(qtlSumStatsExample) @@ -763,65 +673,74 @@ setGeneric("varY", function(x, ...) standardGeneric("varY")) #' @export setGeneric("sumStats", function(x, ...) standardGeneric("sumStats")) -#' @title Get the Embedded QtlDataset List -#' @description Return the named list of \code{QtlDataset} objects carried by a -#' \code{MultiStudyQtlDataset}. -#' @param x A \code{MultiStudyQtlDataset} object. -#' @return A named list of \code{QtlDataset} objects. -#' @examples -#' data(multiStudyQtlDatasetExample) -#' qtlDatasets(multiStudyQtlDatasetExample) +#' @title Get the Per-Row QC Audit +#' @description What \code{\link{summaryStatsQc}} did to each row of a +#' summary-statistics collection: one row per tuple, its identity columns, +#' then the variant counts each QC step recorded (\code{variantsIn}, +#' \code{variantsOut}, and so on; a nested count is named by its path, as +#' in \code{contentFilters.nDropped}). A step that did not run on a row is +#' \code{NA} there. Only the identity columns are present before QC has run. +#' The options the QC ran with are \code{\link{qcOptions}}; the per-variant +#' LD-mismatch tables are \code{\link{qcDiagnostics}}. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param ... Unused. +#' @return A \code{DataFrame}, one row per tuple. #' @export -setGeneric("qtlDatasets", function(x) standardGeneric("qtlDatasets")) +setGeneric("qcInfo", function(x, ...) standardGeneric("qcInfo")) -#' @title Get QC Audit Record -#' @description Return the audit record of QC steps applied to this collection. -#' An empty \code{list()} (default on construction) means -#' \code{\link{summaryStatsQc}} has not yet been run. Pipelines that require -#' harmonized sumstats (\code{fineMappingPipeline}, -#' \code{twasWeightsPipeline}, and downstream consumers) reject inputs where -#' \code{length(qcInfo(x)) == 0L}. +#' @title Get the QC Options +#' @description The record of the QC that ran over a summary-statistics +#' collection: the options \code{\link{summaryStatsQc}} was called with and +#' when. An empty \code{list()} (the default on construction) means QC has +#' not run; pipelines that need harmonized summary statistics +#' (\code{fineMappingPipeline}, \code{twasWeightsPipeline} and others) +#' refuse such inputs. What QC did to each row is \code{\link{qcInfo}}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. #' @param ... Unused. -#' @return A \code{list} (possibly empty). +#' @return A \code{list}, possibly empty. #' @export -setGeneric("qcInfo", function(x, ...) standardGeneric("qcInfo")) +setGeneric("qcOptions", function(x, ...) standardGeneric("qcOptions")) #' @title Get SLALOM / DENTIST Diagnostics -#' @description Return the per-variant LD-mismatch diagnostics table (SLALOM or -#' DENTIST output) attached to a sumstats entry by -#' \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not -#' \code{"none"}. -#' Convenience accessor over -#' \code{qcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. +#' @description Return the per-variant LD-mismatch diagnostics (SLALOM or +#' DENTIST output) that \code{\link{summaryStatsQc}} attached to the +#' selected entry when \code{ldMismatchQcMethod} was not \code{"none"}. +#' The selectors pin one study (every row of a GWAS study, whose rows' +#' tables are stacked) or one \code{QtlSumStats} entry, as for +#' \code{\link{sumStats}}. #' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. -#' @param entry Integer index (default 1) of the entry whose diagnostics table -#' to return. When \code{NULL}, returns a named list of every entry's -#' diagnostics keyed by entry index. +#' @param studyName,context,trait Selectors pinning one study or entry; +#' \code{context} and \code{trait} are \code{QtlSumStats}-only. #' @param ... Unused. -#' @return A \code{data.frame} of per-variant diagnostics (columns include -#' \code{variant_id} plus the SLALOM / DENTIST output columns), \code{NULL} -#' when no diagnostics were preserved for that entry, or a named list of such -#' data.frames when \code{entry = NULL}. +#' @return A \code{DataFrame} of per-variant diagnostics (columns include +#' \code{variant_id} plus the SLALOM / DENTIST output columns), or +#' \code{NULL} when no diagnostics were preserved for the selection. #' @export -setGeneric("qcDiagnostics", function(x, entry = 1L, ...) { +setGeneric("qcDiagnostics", function(x, ...) { standardGeneric("qcDiagnostics") }) #' @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). +#' @description Return the LD references of this object, each a genotype +#' panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} +#' or an \code{\link{LdMatrix}}. +#' +#' The collections whose rows can sit on different references -- +#' \code{GwasSumStats}, \code{QtlSumStats}, \code{FineMappingResultBase}, +#' \code{TwasWeights}, \code{ColocResult} and \code{ColocBoostResult} -- +#' return a named list holding each distinct reference their rows use, once. +#' The \code{ldReference} column of their \code{mcols} (of +#' \code{outcomeInfo} for a \code{ColocBoostResult}) names the entry each +#' row used, \code{NA} for one fit without LD (e.g. a \code{TwasWeights} +#' row learned from individual-level data via \code{QtlDataset}). The list +#' is empty when no row has a reference. +#' +#' An \code{LdStatistic} returns the one panel it reads its blocks' LD from, +#' or \code{NULL} when it was built from \code{LdMatrix} blocks. #' @param x An S4 object that carries an \code{ldReference} slot. #' @param ... Unused. -#' @return A \code{RangedSummarizedExperiment} genotype panel, a +#' @return A named list of LD references; for an \code{LdStatistic}, a +#' \code{RangedSummarizedExperiment} genotype panel, a #' \code{GenotypeMixture}, an \code{LdMatrix}, or \code{NULL}. #' @export setGeneric("ldReference", function(x, ...) standardGeneric("ldReference")) @@ -832,34 +751,27 @@ setGeneric("ldReference", function(x, ...) standardGeneric("ldReference")) #' @title Get LD Correlation Matrix #' @description Extract the LD correlation matrix an \code{\link{LdMatrix}} -#' holds, labelled by its variant ids. +#' holds, labelled by its variant ids. \code{as.matrix(x)} and +#' \code{as(x, "matrix")} return the same matrix. #' @param x An \code{LdMatrix}. +#' @param ... Unused. #' @return A correlation matrix. #' @examples #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:8] #' ld <- LdMatrix(cor(X), nSamples = nrow(X)) #' ldMatrix(ld)[1:3, 1:3] +#' identical(as.matrix(ld), ldMatrix(ld)) #' @export setGeneric("ldMatrix", function(x) standardGeneric("ldMatrix")) #' @title Get Genotype Matrix #' @description Extract a genotype matrix from an object that carries genotype -#' 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). +#' data. For a \code{QtlDataset}, the whole dataset's dosages (samples x +#' variants), with no QC applied: to read part of it, narrow the dataset +#' first, e.g. \code{genotypes(x[window, samples, ])}. #' @param x The object to extract from. -#' @param ... Class-specific selection arguments (e.g., \code{traitId}, -#' \code{region}, \code{cisWindow} for \code{QtlDataset}). -#' @param traitId Character or \code{NULL}. Molecular trait / feature identifier -#' to select; \code{NULL} matches all traits in the dataset. -#' @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 cisWindow Integer or \code{NULL}. Half-width (bp) of the cis window -#' 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 ... Passed on to methods. #' @return A numeric matrix, a list of matrices, or \code{NULL}. #' @examples #' data(qtlDatasetExample) @@ -870,7 +782,10 @@ setGeneric("genotypes", function(x, ...) standardGeneric("genotypes")) #' @title Get Variant IDs #' @description Extract variant ID vector from an object that carries one (e.g., #' \code{LdMatrix}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from -#' one entry of a collection class selected by its identity tuple. +#' one entry of a collection class selected by its identity tuple. Every +#' class renders the same canonical \code{chrom:pos:A2:A1} id from each +#' variant's range and alleles; labels a source gave (an rsID, a file's own +#' spelling) stay in the \code{SNP} column of its ranges. #' @param x The object. #' @param ... Class-specific selection arguments. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection @@ -881,13 +796,8 @@ setGeneric("genotypes", function(x, ...) standardGeneric("genotypes")) #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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 annotateSignificance Optional correction-method name passed through to -#' \code{\link{sumStats}} (QTL only); \code{NULL} applies none. -#' @param ranges A \code{GRanges} or \code{NULL} (default). Return only the -#' variants overlapping these ranges; \code{NULL} returns everything. +#' @param blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. #' @return Character vector of variant IDs. #' @examples #' data(qtlFineMappingExample) @@ -897,37 +807,25 @@ setGeneric("variantIds", function(x, ...) standardGeneric("variantIds")) #' @title Get Molecular Traits #' @description Extract molecular-trait data from an object that carries it. -#' For a \code{QtlDataset}, the user can optionally select specific contexts, -#' traits, or a region (see method documentation for the per-class selection -#' arguments). +#' For a \code{QtlDataset}, select contexts and, optionally, traits by +#' name. The data come back as stored: missing values and outliers are a +#' run's phenotype QC (\code{\link{PhenotypeFilterParam}}), applied by the +#' pipelines, not by this accessor. #' @param x The object to extract from. -#' @param ... Class-specific selection arguments (e.g., \code{contexts}, -#' \code{traitId}, \code{region}). -#' @param contexts Character vector. Context(s) whose data to extract. -#' @param traitId Character or \code{NULL}. Molecular trait / feature identifier +#' @param ... Class-specific selection arguments (e.g., \code{context}, +#' \code{trait}). +#' @param context Character vector. Context(s) whose data to extract. +#' @param trait Character or \code{NULL}. Molecular trait / feature identifier #' to select; \code{NULL} matches all traits in the dataset. -#' @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 naAction Character. How to handle missing phenotype values: one of -#' \code{"keep"}, \code{"drop"}, or \code{"impute"}. -#' @param outlierAction Character. How to handle phenotype outliers: one of -#' \code{"keep"} or \code{"drop"}. -#' @param outlierPvalThreshold Numeric. Two-sided p-value threshold for flagging -#' phenotype outliers. Default \code{1e-3}. -#' @param outlierArgs Extra arguments for \code{robustbase::covMcd()}, the -#' robust covariance estimator the outlier rule is built on, supplied with -#' \code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only -#' consulted when \code{outlierAction = "drop"}. -#' @return A \code{SummarizedExperiment} when one context is selected, or a -#' named list of them for several. A \code{QtlDataset} is a +#' @return A named list of \code{SummarizedExperiment}s keyed by context, +#' one per selected context. A \code{QtlDataset} is a #' \code{MultiAssayExperiment}, so these are its experiments; take the #' measurement matrix itself with #' \code{SummarizedExperiment::assay()} rather than asking this accessor #' for one. #' @examples #' data(qtlDatasetExample) -#' molecularTraits(qtlDatasetExample, contexts = "brain") +#' molecularTraits(qtlDatasetExample, context = "brain") #' @export setGeneric("molecularTraits", function(x, ...) { standardGeneric("molecularTraits") @@ -936,15 +834,21 @@ setGeneric("molecularTraits", function(x, ...) { # Fine-mapping result accessor generics # ============================================================================= -#' @title Get a Single Fine-Mapping Entry -#' @description Return one row of a \code{QtlFineMappingResult} or -#' \code{GwasFineMappingResult}, selected by its identity, as a single-row -#' collection of the same class. +#' @title Get One Fine-Mapping Fit +#' @description Return the rows of one fit of a \code{QtlFineMappingResult} +#' or \code{GwasFineMappingResult}, selected by its identity, as a +#' collection of the same class. A QTL fit is one row. A GWAS study +#' fine-mapped block by block holds one row per LD block, so its fit is +#' every block of the \code{(study, method)} pair, unless \code{blockId} +#' names one or \code{region} narrows them. #' @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 single-row collection of the same class as \code{x}. +#' @param studyName,context,trait,method Single character identifiers. +#' Required when the collection holds more than one fit; optional when it +#' holds one. \code{context} and \code{trait} are QTL-only. +#' @param blockId GWAS only: the \code{blockId} of one LD block, to select +#' that block alone. \code{NULL} (default) selects every block of the fit. +#' @return A collection of the same class as \code{x}: one row for a QTL fit, +#' one row per selected block for a GWAS fit. #' @examples #' data(qtlFineMappingExample) #' fineMappingResult(qtlFineMappingExample, studyName = "study_1", @@ -952,7 +856,14 @@ setGeneric("molecularTraits", function(x, ...) { #' @export setGeneric( "fineMappingResult", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + blockId = NULL + ) { standardGeneric("fineMappingResult") } ) @@ -999,11 +910,8 @@ setGeneric("adjustPips", function(x, keepVariants, ...) { #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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 returnList Logical. If \code{TRUE}, return a per-entry list keyed by -#' identity tuple instead of a single flattened vector. +#' @param blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. #' @return A named numeric vector of PIPs. #' @examples #' data(qtlFineMappingExample) @@ -1027,9 +935,8 @@ setGeneric("pip", function(x, ...) standardGeneric("pip")) #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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 blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. #' @return A list (the SuSiE fit object). #' @examples #' data(qtlFineMappingExample) @@ -1039,12 +946,12 @@ setGeneric("susieFit", function(x, ...) standardGeneric("susieFit")) #' @title Compute Between-Credible-Set Correlation On Demand #' @description Compute the between-credible-set correlation matrix for a -#' \code{\link{fineMappingRow}} on demand from an LD source. The correlation +#' \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 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 +#' @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 @@ -1110,13 +1017,12 @@ setGeneric("cvResult", function(x, ...) standardGeneric("cvResult")) #' @title Get Marginal Effects #' @description Extract per-variant marginal univariate effects from a -#' fine-mapping entry or result. Returns a \code{data.frame} with identity -#' 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. +#' fine-mapping entry or result, one range per variant. Its \code{mcols()} +#' hold the identity 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{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. #' @param studyName Character (length 1) or \code{NULL}. Restrict the selection #' to this study; \code{NULL} matches all studies. @@ -1126,15 +1032,16 @@ setGeneric("cvResult", function(x, ...) standardGeneric("cvResult")) #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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. -#' @return A \code{data.frame}. +#' @param blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. +#' @return A \code{GRanges}, one range per variant; when the selectors match +#' more than one entry the row-identity columns are carried in +#' \code{mcols()} too. #' @examples #' data(qtlFineMappingExample) #' marginalEffects(qtlFineMappingExample) #' @export -setGeneric("marginalEffects", function(x, maxPval = NULL, ...) { +setGeneric("marginalEffects", function(x, ...) { standardGeneric("marginalEffects") }) @@ -1159,22 +1066,17 @@ setGeneric("marginalEffects", function(x, maxPval = NULL, ...) { #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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 blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. #' @param minPurity Numeric or \code{NULL}. Minimum credible-set purity to #' retain; \code{NULL} applies no purity filter. -#' @param raw Logical (length 1). \code{FALSE} (default) returns the posterior -#' view described above. \code{TRUE} hands back the stored canonical table -#' verbatim -- a \code{data.frame}, not a \code{GRanges} -- so neither the -#' projection nor \code{signalCutoff} applies. #' @return A \code{GRanges}, one range per retained variant, carrying the #' per-variant columns in \code{mcols()}; when the selectors match more than #' one entry the row-identity columns are carried there too. Take a table #' with \code{as.data.frame()} (which adds the standard #' \code{seqnames}/\code{start}/... columns) or #' \code{as.data.frame(S4Vectors::mcols(.))} for the per-variant columns -#' alone. \code{raw = TRUE} returns the stored \code{data.frame} instead. +#' alone. #' @examples #' data(qtlFineMappingExample) #' topLoci(qtlFineMappingExample) @@ -1196,14 +1098,17 @@ setGeneric( #' this trait; \code{NULL} matches all traits. #' @param method Character (length 1) or \code{NULL}. Restrict the selection to #' this fine-mapping / weight method; \code{NULL} matches all methods. -#' @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 blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block of a fit; \code{NULL} matches every block. #' @param coverage Numeric in (0, 1). Credible-set coverage level. Default #' \code{0.95}. #' @param minPurity Numeric or \code{NULL}. Minimum credible-set purity to #' retain; \code{NULL} applies no purity filter. -#' @return A data.frame of credible set information. +#' @return A \code{GRanges}, one range per credible-set member, carrying the +#' per-variant columns in \code{mcols()}; when the selectors match more +#' than one entry the row-identity columns are carried there too. Narrow it +#' with \code{subsetByOverlaps()}; take a table with +#' \code{as.data.frame()}. #' @examples #' data(qtlFineMappingExample) #' credibleSets(qtlFineMappingExample) @@ -1226,9 +1131,8 @@ setGeneric("credibleSets", function(x, ...) standardGeneric("credibleSets")) #' @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 fine-mapping result, whose rows also carry a -#' region; \code{NULL} (default) leaves it unconstrained. +#' @param blockId GWAS fine-mapping results only: the \code{blockId} naming +#' one LD block; \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. @@ -1246,7 +1150,12 @@ setGeneric("resolveWeights", function(x, ...) standardGeneric("resolveWeights")) #' collection (aggregated across rows, tagged with run identity). #' @param x A \code{CtwasResultEntry} or \code{CtwasResult}. #' @param ... Class-specific selection arguments. -#' @return A \code{data.frame} of posteriors (or \code{NULL} when absent). +#' @return On a \code{CtwasResultEntry}, the stored posteriors: a +#' \code{GRanges} when the pipeline placed its rows (each table column in +#' \code{mcols()}), the table as given otherwise, or \code{NULL} when +#' absent. On a \code{CtwasResult}, one \code{GRanges} of every row's +#' posteriors with the run identity in \code{mcols()} (empty when no row +#' has any); a row whose payload carries no coordinates is an error. #' @examples #' cre <- CtwasResultEntry( #' posteriors = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), @@ -1265,8 +1174,11 @@ setGeneric("ctwasPosteriors", function(x, ...) { #' cTWAS output retained so the raw run is reconstructable. #' @param x A \code{CtwasResultEntry} or \code{CtwasResult}. #' @param ... Class-specific selection arguments. -#' @return A \code{data.frame} of per-effect alphas (or \code{NULL} when -#' absent). +#' @return On a \code{CtwasResultEntry}, the stored alphas: a +#' \code{GRanges} when the pipeline placed its rows, the table as given +#' otherwise, or \code{NULL} when absent. On a \code{CtwasResult}, one +#' \code{GRanges} of every row's alphas with the run identity in +#' \code{mcols()} (empty when no row has any). #' @examples #' cre <- CtwasResultEntry( #' posteriors = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), @@ -1384,7 +1296,7 @@ setGeneric("methodNames", function(x) standardGeneric("methodNames")) #' this fine-mapping / weight method; \code{NULL} matches all methods. #' @return A character vector or NULL. #' @examples -#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), +#' twe <- TwasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), #' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), #' weightStandardized = FALSE) #' weightsDataType(twe) @@ -1397,23 +1309,27 @@ setGeneric("weightsDataType", function(x, ...) { # Published-output generics (VCF/BCF and BED) # ============================================================================= -#' Export a result to VCF/BCF +#' Write a result to VCF/BCF #' #' Writes GWAS summary statistics, fine-mapping results or TWAS weights to a -#' GWAS-VCF-style file via VariantAnnotation and Rsamtools: one record per -#' variant, one SAMPLE per study / fitted model, and the per-variant statistics -#' as FORMAT fields. Supports bgzipped VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) -#' additionally needs a working \code{Rsamtools::asBcf()}, which recent -#' Rsamtools releases disable, so prefer .vcf.bgz. +#' GWAS-VCF-style file: one record per variant, one SAMPLE per study / fitted +#' model, and the per-variant statistics as FORMAT fields. The file is written +#' with VariantAnnotation's \code{\link[VariantAnnotation]{writeVcf}}, so that +#' package must be installed. +#' Supports bgzipped VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) additionally needs a +#' working \code{Rsamtools::asBcf()}, which recent Rsamtools releases disable, +#' so prefer .vcf.bgz. #' #' Which FORMAT fields are written depends on the input: #' \describe{ -#' \item{\code{GwasSumStats}}{\code{ES} / \code{SS} / \code{AF} for one -#' study.} +#' \item{\code{GwasSumStats}}{\code{ES} / \code{SE} / \code{EZ} / +#' \code{NS} / \code{AF} / \code{MAF} for one study, whichever its +#' variants carry.} #' \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).} +#' \code{SE}, \code{EZ}, \code{LP}, \code{NS}), the fit's own +#' (\code{AF}, \code{WGT}, \code{WGTSE}, \code{THETA}) and the +#' posterior ones (\code{PIP}, \code{LBF}, \code{LFSR}, and a +#' \code{CS}/\code{PUR} pair per credible-set coverage present).} #' \item{\code{TwasWeights}}{\code{WGT}, the prediction weight.} #' } #' @@ -1424,17 +1340,28 @@ setGeneric("weightsDataType", function(x, ...) { #' methods for one gene, are compared by reading one file rather than a dozen. #' Each sample is described in its own \code{##SAMPLE} header line, carrying #' the fit's identity tuple and how many variants it contributed. -#' Cross-validation results are not exported -- see \code{\link{exportToBed}} -#' for why -- and an export requires the full-data fit. +#' Cross-validation results are not written -- see \code{\link{writeBed}} for +#' why -- and writing requires the full-data fit. +#' +#' A GWAS study fine-mapped block by block is ONE fit, so its blocks are +#' joined into one sample. A \code{BID} FORMAT field then names each +#' variant's LD block -- credible-set indices are numbered within a block, +#' so a set is the \code{(BID, CS)} pair -- and the per-block header values +#' (block id, analysis window and whether it was given, \code{V}, +#' \code{cs_index}) are packed in block order, separated by \code{|}. +#' \code{\link{readFineMappingResult}} splits such a sample back into its +#' blocks. #' #' \code{splitByContext} / \code{splitByTrait} opt out of that and write one -#' single-sample file per fit, at a path decorated with the axis value. +#' file per context / trait, at a path decorated with the axis value, holding +#' the fits that share it. \code{splitByBlock} writes one file per LD block +#' of a GWAS result, each holding every fit's part of that block. #' -#' @param x A \code{GwasSumStats}, \code{QtlFineMappingResult}, +#' @param obj 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: +#' @param filename 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. #' @param sampleName Name(s) for the VCF sample column(s). Default \code{NULL} @@ -1451,26 +1378,28 @@ setGeneric("weightsDataType", function(x, ...) { #' Default \code{FALSE}. #' @param splitByTrait Logical. If \code{TRUE}, write one VCF per trait. Default #' \code{FALSE}. +#' @param splitByBlock Logical. \code{GwasFineMappingResult} only: if +#' \code{TRUE}, write one VCF per LD block instead of joining a study's +#' blocks into one file. Default \code{FALSE}. #' @param ... Additional arguments passed to methods. #' @return Invisible path(s) to the written file(s). -#' @seealso \code{\link{exportToBed}} +#' @seealso \code{\link{writeBed}}, \code{\link{readFineMappingResult}} #' @examples #' data(gwasSumStatsS4Example) -#' exportToVcf( -#' gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) +#' writeGwasVcf(gwasSumStatsS4Example, tempfile(fileext = ".vcf")) #' @export -setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { - standardGeneric("exportToVcf") +setGeneric("writeGwasVcf", function(obj, filename, ...) { + standardGeneric("writeGwasVcf") }) -#' Export a result to a published BED table +#' Write a result to a published BED table #' #' Writes fine-mapping results or TWAS weights to a published FunGen-xQTL BED #' table, bgzipping and tabix-indexing the output when the path ends in #' \code{.gz} / \code{.bgz}. The tabular counterpart of -#' \code{\link{exportToVcf}}: the VCF is one record per variant with the models -#' as samples, while these tables are long-format, one row per published -#' observation. +#' \code{\link{writeGwasVcf}}: the VCF is one record per variant +#' with the models as samples, while these tables are long-format, one row per +#' published observation. #' #' A \code{TwasWeights} writes one table, a row per (variant, weight column). #' A fine-mapping result offers two, selected with \code{schema}: @@ -1487,19 +1416,19 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' \code{method} -- because these collections are keyed by that tuple and #' several of them are routinely folded into one output. #' -#' Cross-validation results are NOT exported, in any schema. They describe how +#' Cross-validation results are NOT written, in any schema. They describe how #' a model scored on held-out FOLDS; nothing about them is per-variant, and a #' published file has no data-secure way to express anything fold-level, #' because fold membership is sample-level information and sample names can be #' protected. They remain on the object, where \code{\link{cvResult}} returns -#' them and the caller tabulates whatever they need. For the same reason an -#' export REQUIRES the full-data fit: a cross-validation-only collection (what -#' \code{twasWeightsPipeline(fitFullData = FALSE)} produces) is refused rather -#' than written out empty. +#' them and the caller tabulates whatever they need. For the same reason +#' writing REQUIRES the full-data fit: a cross-validation-only collection +#' (what \code{twasWeightsPipeline(fitFullData = FALSE)} produces) is refused +#' rather than written out empty. #' -#' @param x A \code{QtlFineMappingResult}, \code{GwasFineMappingResult} or +#' @param obj 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 +#' @param filename 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 Fine-mapping results only: which published schema to @@ -1532,8 +1461,7 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' (\code{grange_start} / \code{grange_end}, the legacy \code{gene} / #' \code{event} aliases, and whatever a custom build added); a #' \code{TwasWeights} element carries only its alleles and weight, so there -#' is nothing further to add unless the collection was built by hand. Not -#' accepted by the \code{"performance"} schema, which has no variant axis. +#' is nothing further to add unless the collection was built by hand. #' @param extraColumns Optional NAMED list of trailing columns to append after #' the published schema. Each element is either length 1 (recycled across #' every row) or one value per row. For fields no S4 object can know -- the @@ -1541,20 +1469,21 @@ setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { #' is the motivating case. Names that collide with a published column are an #' error rather than a silent overwrite. #' @param ... Additional arguments passed to methods. -#' @return \code{outputPath}, invisibly. -#' @seealso \code{\link{exportToVcf}}, \code{\link{genomicOrder}} +#' @return \code{filename}, invisibly. +#' @seealso \code{\link{writeGwasVcf}}, +#' \code{\link{readFineMappingResult}}, \code{\link{genomicOrder}} #' @examples #' data(qtlFineMappingExample) -#' exportToBed(qtlFineMappingExample, tempfile(fileext = ".bed")) -#' exportToBed( +#' writeBed(qtlFineMappingExample, tempfile(fileext = ".bed")) +#' writeBed( #' qtlFineMappingExample, tempfile(fileext = ".bed"), #' schema = "topLoci", columns = "all" #' ) #' data(twasWeightsExample) -#' exportToBed(twasWeightsExample, tempfile(fileext = ".bed")) +#' writeBed(twasWeightsExample, tempfile(fileext = ".bed")) #' @export -setGeneric("exportToBed", function(x, outputPath, ...) { - standardGeneric("exportToBed") +setGeneric("writeBed", function(obj, filename, ...) { + standardGeneric("writeBed") }) # ============================================================================= @@ -1597,10 +1526,13 @@ 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 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). +#' \code{TwasWeights}; 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}); for summary statistics the +#' LD block or window the row was loaded for (the \code{region} given to the +#' constructor or loader), else the span of its variants before QC. This is +#' location provenance (e.g. for cTWAS LD-block placement). One method +#' serves every collection. #' #' This is the window that was ANALYSED, not the span of the variants that #' survived into the fit: QC and screening drop variants first, so a fit over @@ -1609,7 +1541,7 @@ setGeneric("traitNames", function(x) standardGeneric("traitNames")) #' recovered from the object; the span can, and is simply \code{range(x)}. #' #' Being a record of what was analysed, it deliberately does NOT change under -#' \code{subsetRegion()} or row subsetting -- a subset of a fit's variants was +#' subsetting -- a subset of a fit's variants was #' still produced by a fit over the original window. Use \code{range(x)} when #' you want the current content instead. #' @@ -1634,11 +1566,13 @@ setGeneric("genomicRegion", function(x, ...) standardGeneric("genomicRegion")) #' on, so the returned vector is always the same length as \code{nrow(x)} #' and can be used to label or join rows directly. #' -#' It keys the external block manifest the blocks were defined in, and so -#' carries the true block BOUNDARIES --- unlike \code{range(x)}, which is -#' the span of the variants that survived QC. A collection with no block -#' axis (every QTL flavour) returns \code{NA} for every row rather than -#' erroring, so code that handles both flavours needs no class test. +#' It keys the external block manifest the blocks were defined in. The +#' block's BOUNDARIES are the \code{region} column, recorded as given or +#' computed in \code{regionGiven} (see \code{\linkS4class{GwasSumStats}}) +#' --- unlike \code{range(x)}, which is the span of the variants that +#' survived QC. A collection with no block axis (every QTL flavour) +#' returns \code{NA} for every row rather than erroring, so code that +#' handles both flavours needs no class test. #' @param x The object. #' @param ... Reserved for future use. #' @return Character, one value per row of \code{x} (\code{NA} where the row @@ -1663,10 +1597,13 @@ setGeneric("blockId", function(x, ...) standardGeneric("blockId")) #' \code{QtlFineMappingResult} and \code{TwasWeights}. #' @param x The object. #' @param ... Reserved for future use. -#' @param traitId Character or \code{NULL}. Molecular trait / feature identifier +#' @param trait Character or \code{NULL}. Molecular trait / feature identifier #' to select; \code{NULL} matches all traits in the dataset. -#' @return A \code{GRanges} with one range per row of \code{x}, or an empty -#' \code{GRanges} when the collection carries no trait-position provenance. +#' @return A \code{GRanges}: one range per row of a collection, or an empty +#' \code{GRanges} when the collection carries no trait-position provenance +#' (or, for a \code{QtlSumStats} with \code{trait} given, none of those +#' traits). For a \code{QtlDataset}, one range per requested trait, named +#' by trait; a trait in no context is an error. #' @export setGeneric("traitPosition", function(x, ...) { standardGeneric("traitPosition") @@ -1674,25 +1611,12 @@ setGeneric("traitPosition", function(x, ...) { #' @title Get Residualized Genotypes #' @description Residualize the genotype matrix against the per-context -#' phenotype covariates and the genotype covariates, optionally subsetting -#' variants to those falling within a trait's cis-window or an explicit -#' region. +#' phenotype covariates and the genotype covariates, over the whole +#' dataset: narrow it first, with \code{x[i, j, ]}, to residualize part +#' of it. #' @param x A \code{QtlDataset} object. -#' @param ... Selection arguments: \code{traitId}, \code{region}, -#' \code{cisWindow}, \code{phenotypeCovariatesToRemove}, -#' \code{genotypeCovariatesToRemove}, and \code{covariateNaAction} -#' (\code{"impute"}, the default, mean-imputes missing covariate cells; -#' \code{"drop"} removes samples with any missing covariate). -#' @param contexts Character vector. Context(s) whose data to extract. -#' @param traitId Character or \code{NULL}. Molecular trait / feature identifier -#' to select; \code{NULL} matches all traits in the dataset. -#' @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 cisWindow Integer or \code{NULL}. Half-width (bp) of the cis window -#' 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 ... Passed on to methods. +#' @param context Character vector. Context(s) whose data to extract. #' @param residualizationParam What the data is residualized on, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and #' \code{genotypeCovariates} choose the covariate sets, @@ -1703,7 +1627,7 @@ setGeneric("traitPosition", function(x, ...) { #' @return A numeric matrix (samples x variants). #' @examples #' data(qtlDatasetExample) -#' residualizedGenotypes(qtlDatasetExample, contexts = "brain") +#' residualizedGenotypes(qtlDatasetExample, context = "brain") #' @export setGeneric("residualizedGenotypes", function(x, ...) { standardGeneric("residualizedGenotypes") @@ -1712,19 +1636,14 @@ setGeneric("residualizedGenotypes", function(x, ...) { #' @title Get Residualized Phenotypes #' @description Residualize the per-context phenotype matrices against the #' per-context phenotype covariates and the genotype covariates, for one or -#' more requested contexts. +#' more requested contexts. Missing values and outliers are left as they +#' are: they are a run's phenotype QC (\code{\link{PhenotypeFilterParam}}), +#' applied by the pipelines. #' @param x A \code{QtlDataset} object. -#' @param ... Selection arguments: \code{contexts} (required), \code{traitId}, -#' \code{region}, \code{phenotypeCovariatesToRemove}, -#' \code{genotypeCovariatesToRemove}, and \code{covariateNaAction} -#' (\code{"impute"}, the default, mean-imputes missing covariate cells; -#' \code{"drop"} removes samples with any missing covariate). -#' @param contexts Character vector. Context(s) whose data to extract. -#' @param traitId Character or \code{NULL}. Molecular trait / feature identifier +#' @param ... Passed on to methods. +#' @param context Character vector. Context(s) whose data to extract. +#' @param trait Character or \code{NULL}. Molecular trait / feature identifier #' to select; \code{NULL} matches all traits in the dataset. -#' @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 residualizationParam What the data is residualized on, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and #' \code{genotypeCovariates} choose the covariate sets, @@ -1732,20 +1651,10 @@ setGeneric("residualizedGenotypes", function(x, ...) { #' side on or off, and \code{covariateNaAction} says how missing #' covariate values are handled. The same record the pipelines take, so a #' setting means the same thing by either route. -#' @param naAction Character. How to handle missing phenotype values: one of -#' \code{"keep"}, \code{"drop"}, or \code{"impute"}. -#' @param outlierAction Character. How to handle phenotype outliers: one of -#' \code{"keep"} or \code{"drop"}. -#' @param outlierPvalThreshold Numeric. Two-sided p-value threshold for flagging -#' phenotype outliers. Default \code{1e-3}. -#' @param outlierArgs Extra arguments for \code{robustbase::covMcd()}, the -#' robust covariance estimator the outlier rule is built on, supplied with -#' \code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only -#' consulted when \code{outlierAction = "drop"}. #' @return A named list of numeric matrices keyed by context. #' @examples #' data(qtlDatasetExample) -#' residualizedPhenotypes(qtlDatasetExample, contexts = "brain") +#' residualizedPhenotypes(qtlDatasetExample, context = "brain") #' @export setGeneric("residualizedPhenotypes", function(x, ...) { standardGeneric("residualizedPhenotypes") @@ -1755,14 +1664,14 @@ setGeneric("residualizedPhenotypes", function(x, ...) { #' @description Return per-context phenotype covariate matrices, taken from the #' \code{colData} of each context's \code{SummarizedExperiment}. #' @param x A \code{QtlDataset} object. -#' @param contexts Character vector of context names (subset of +#' @param context Character vector of context names (subset of #' \code{names(molecularTraits(x))}). #' @return A named list of matrices keyed by context. #' @examples #' data(qtlDatasetExample) -#' phenotypeCovariates(qtlDatasetExample, contexts = "brain") +#' phenotypeCovariates(qtlDatasetExample, context = "brain") #' @export -setGeneric("phenotypeCovariates", function(x, contexts) { +setGeneric("phenotypeCovariates", function(x, context) { standardGeneric("phenotypeCovariates") }) @@ -1779,19 +1688,6 @@ setGeneric("genotypeCovariates", function(x) { standardGeneric("genotypeCovariates") }) -#' @title Get scaleResiduals Flag -#' @description Whether residualization accessors scale residuals to unit -#' variance. -#' @param x A \code{QtlDataset} object. -#' @return Logical (length 1). -#' @examples -#' data(qtlDatasetExample) -#' scaleResiduals(qtlDatasetExample) -#' @export -setGeneric("scaleResiduals", function(x) { - standardGeneric("scaleResiduals") -}) - # ============================================================================= # GenotypeHandle / LD-statistic / LdMatrix / Annotation / H2Estimate accessors # ============================================================================= @@ -1907,7 +1803,6 @@ setGeneric("ldMatrixList", function(x) standardGeneric("ldMatrixList")) #' @export setGeneric("ldBlocks", function(x) standardGeneric("ldBlocks")) - #' @title Get GenotypeHandle #' @description Return the \code{GenotypeHandle} behind a \code{QtlDataset}'s #' genotype experiment. @@ -2033,7 +1928,7 @@ setGeneric("construct", function(pipeline, records, ...) { # ---- SldscData accessors ---- #' @title Get the annotation table from an SldscData #' @param x An \code{\link{SldscData}} object. -#' @return A \code{data.frame} of annotations (CHR, SNP, annotation columns). +#' @return A \code{DataFrame} of annotations (CHR, SNP, annotation columns). #' @rdname annotData #' @examples #' mkRun <- function(cats) { @@ -2065,7 +1960,7 @@ setGeneric("annotData", function(x) standardGeneric("annotData")) #' @title Get the allele-frequency table from an SldscData #' @param x An \code{\link{SldscData}} object. -#' @return A \code{data.frame} of reference-panel frequencies (SNP, MAF). +#' @return A \code{DataFrame} of reference-panel frequencies (SNP, MAF). #' @rdname frqData #' @examples #' mkRun <- function(cats) { @@ -2150,17 +2045,16 @@ setGeneric("testedAnnotations", function(x) { #' @title Get sLDSC Results from an SldscData #' @description Return the stratified LD-score regression runs held by an -#' \code{\link{SldscData}}: every trait's runs when \code{trait} is -#' \code{NULL}, otherwise the selected run(s) for that one trait. +#' \code{\link{SldscData}}, keyed by trait. Each trait's entry holds its +#' \code{single} runs (one per annotation) and its \code{joint} run, read +#' with \code{[[}: \code{sldscResults(x, "T")[["T"]]$joint}. #' @param x An \code{\link{SldscData}} object. -#' @param trait Character trait name, or \code{NULL} (default) to return the -#' named list of per-trait \code{single}/\code{joint} runs for all traits. -#' @param ... Further arguments: \code{mode} (\code{"single"}/\code{"joint"}) -#' and \code{idx} (which single run). -#' @param mode Character. Trait-run selection mode. -#' @param idx Integer. Index of the trait run to select. -#' @return The named list of per-trait runs when \code{trait} is \code{NULL}; -#' otherwise a single run list, the list of single runs, or \code{NULL}. +#' @param trait Character trait name(s), or \code{NULL} (default) for every +#' trait. A name the object does not hold is an error. +#' @param ... Unused. +#' @return A named list keyed by trait, each element a list with +#' \code{single} (a list of runs) and \code{joint} (one run, or +#' \code{NULL} when the trait has none). #' @rdname sldscResults #' @examples #' mkRun <- function(cats) { @@ -2186,14 +2080,14 @@ setGeneric("testedAnnotations", function(x) { #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) #' sd <- SldscData(annotData = annot, frqData = frq, traits = traits) -#' sldscResults(sd, "traitX") +#' sldscResults(sd, "traitX")[["traitX"]]$joint$categories #' @export setGeneric("sldscResults", function(x, trait = NULL, ...) { standardGeneric("sldscResults") }) #' @title Colocalization Views -#' @description The four views over a \code{\linkS4class{ColocResult}}. The +#' @description The five views over a \code{\linkS4class{ColocResult}}. The #' object stores one element per tested (QTL credible set, GWAS credible set, #' block) pair; these accessors project it to the granularity a given #' analysis needs, rather than any one of them being the stored shape. @@ -2203,13 +2097,19 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' \code{$summary} granularity. Every testable pair is reported verbatim, #' including both halves of a credible set that straddles a block #' boundary; interpreting them is the caller's decision.} -#' \item{\code{colocVariants()}}{One row per (pair, variant), carrying +#' \item{\code{colocVariants()}}{One range per (pair, variant), carrying #' \code{colocPp = PP.H4.abf * SNP.PP.H4} -- the posterior that this -#' variant is the shared causal one. With \code{pooled = TRUE}, one row -#' per (gene, variant) pooled by the rule below.} -#' \item{\code{colocCredibleSets()}}{One row per coloc credible set: the -#' smallest set of variants whose cumulative \code{SNP.PP.H4} reaches -#' \code{coverage}. This is a THIRD variant set, not guaranteed to be a +#' variant is the shared causal one.} +#' \item{\code{colocPooledVariants()}}{One range per (gene, variant), +#' pooled across pairs by the rule below. A +#' \code{\linkS4class{ColocBoostResult}} pools per (analysis, variant) +#' instead, with the noisy-OR stage only.} +#' \item{\code{colocCredibleSets()}}{One element per coloc credible set: +#' the smallest set of variants whose cumulative \code{SNP.PP.H4} +#' reaches \code{coverage}, as ranges carrying their \code{SNP.PP.H4}, +#' with the set's pair columns, \code{csSize}, \code{csCoverage}, +#' \code{leadVariant}, \code{leadPp} and \code{purity} in +#' \code{mcols()}. This is a THIRD variant set, not guaranteed to be a #' subset of either input credible set, so its purity is recomputed from #' LD rather than inherited.} #' \item{\code{colocGenes()}}{One row per gene, pooled across pairs.} @@ -2224,8 +2124,6 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' combine as \code{1 - prod_i (1 - p_i)}. #' #' @param x A \code{ColocResult}. -#' @param pooled Logical. \code{colocVariants()} only: pool to one row per -#' (gene, variant) instead of per (pair, variant). #' @param coverage Cumulative \code{SNP.PP.H4} the credible set must reach. #' @param minPp4 Optional lower bound on the pair's \code{PP.H4.abf}. Applied #' before any LD work, so a stricter threshold costs strictly less. @@ -2237,7 +2135,10 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' (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. +#' @return \code{colocVariants()} and \code{colocPooledVariants()} a +#' \code{GRanges}, its columns in \code{mcols()}; +#' \code{colocCredibleSets()} a \code{GRangesList}, one element per set; +#' the other views a \code{DataFrame}. #' @name colocViews #' @rdname colocViews #' @examples @@ -2249,6 +2150,7 @@ setGeneric("sldscResults", function(x, trait = NULL, ...) { #' ) #' head(colocPairs(res)) #' head(colocVariants(res)) +#' head(colocPooledVariants(res)) #' colocGenes(res) #' head(colocCredibleSets(res, minPp4 = 0.001)) NULL @@ -2261,10 +2163,16 @@ setGeneric("colocPairs", function(x, ...) { #' @rdname colocViews #' @export -setGeneric("colocVariants", function(x, pooled = FALSE, ...) { +setGeneric("colocVariants", function(x, ...) { standardGeneric("colocVariants") }) +#' @rdname colocViews +#' @export +setGeneric("colocPooledVariants", function(x, ...) { + standardGeneric("colocPooledVariants") +}) + #' @rdname colocViews #' @export setGeneric( @@ -2280,54 +2188,6 @@ setGeneric("colocGenes", function(x, ...) { standardGeneric("colocGenes") }) -#' @title QtlDataset Filter Settings -#' @description The variant- and sample-filter settings a -#' \code{\link{QtlDataset}} was built with. They are recorded on the object -#' rather than reapplied per call, so reading them back is how a caller finds -#' out what a dataset already excludes. -#' @param x A \code{QtlDataset}. -#' @param ... Additional arguments passed on to methods. -#' @return \code{mafCutoff()}, \code{macCutoff()}, -#' \code{xvarCutoff()} and \code{imissCutoff()} single numerics; -#' \code{keepVariants()} a character vector (empty when no restriction -#' was requested); \code{keepIndel()} a single logical. The sample set -#' is not among them: it lives in \code{colData(x)} and \code{sampleMap(x)}. -#' @name qtlDatasetFilters -#' @rdname qtlDatasetFilters -#' @examples -#' data(qtlDatasetExample) -#' mafCutoff(qtlDatasetExample) -#' keepIndel(qtlDatasetExample) -NULL - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("mafCutoff", function(x, ...) standardGeneric("mafCutoff")) - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("macCutoff", function(x, ...) standardGeneric("macCutoff")) - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("xvarCutoff", function(x, ...) standardGeneric("xvarCutoff")) - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("imissCutoff", function(x, ...) { - standardGeneric("imissCutoff") -}) - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("keepVariants", function(x, ...) { - standardGeneric("keepVariants") -}) - -#' @rdname qtlDatasetFilters -#' @export -setGeneric("keepIndel", function(x, ...) standardGeneric("keepIndel")) - #' @title Get Per-Chromosome Payload Paths #' @description The chromosome-to-path map of a sharded #' \code{\link{GenotypeHandle}}. Empty (\code{character(0)}) for a @@ -2336,8 +2196,8 @@ setGeneric("keepIndel", function(x, ...) standardGeneric("keepIndel")) #' routed by chromosome. #' @param x A \code{GenotypeHandle}. #' @param ... Additional arguments passed on to methods. -#' @return A named character vector mapping canonical chromosome to path or -#' prefix, possibly empty. +#' @return A named character vector mapping each chromosome, in UCSC style +#' (\code{"chr21"}), to its path or prefix, possibly empty. #' @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. @@ -2347,7 +2207,7 @@ setGeneric("chromPaths", function(x, ...) standardGeneric("chromPaths")) #' Per-variant per-effect log Bayes factors (wide) #' #' The variant x effect matrix of single-effect log Bayes factors -#' (\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row +#' (\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one range #' per variant, one \code{lbf_L} column per effect. The per-variant scalar #' summary (max across effects) is the \code{logBF} column of #' \code{\link{topLoci}}; this accessor keeps the full per-effect breakdown. @@ -2356,8 +2216,9 @@ setGeneric("chromPaths", function(x, ...) standardGeneric("chromPaths")) #' #' @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). +#' @return A \code{GRanges}, one range per variant, whose \code{mcols()} +#' hold \code{variant_id} + \code{lbf_L1..lbf_LL} (the collection method +#' also carries the entry identity columns). #' @seealso \code{\link{topLoci}} (the scalar \code{logBF} column) #' @examples #' data(qtlFineMappingExample) @@ -2375,7 +2236,7 @@ setGeneric("lbf", function(x, ...) standardGeneric("lbf")) #' @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, +#' @return A \code{DataFrame}: \code{cs, effect_id, coverage, n_variants, #' purity_min, purity_mean, V, cs_log10bf} (strongest member logBF), #' \code{cs_log_bf} (true per-effect single-effect log Bayes factor), #' \code{cs_pip} (summed member PIP = inclusion mass captured), @@ -2395,18 +2256,20 @@ setGeneric("credibleSetSummary", function(x, ...) { #' #' For a functional-SuSiE (\code{fsusieR::susiF}) fine-mapping entry, returns #' the fitted effect curve and its credible band over the functional grid, one -#' row per (credible set, grid position). Wraps the upstream fSuSiE band +#' range per (credible set, grid position). Wraps the upstream fSuSiE band #' computation (fsusieR's internal \code{update_cal_credible_band.susiF} + #' \code{get_fitted_effect}). Uses saved bands in trimmed fits, or computes -#' them from an untrimmed fit. Returns zero rows when the functional fields -#' are absent. +#' them from an untrimmed fit. Returns an empty \code{GRanges} when the +#' functional fields are absent. #' #' @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 -#' symmetric band half-width publication tables carry (the collection method -#' additionally carries the entry identity columns). +#' @return A \code{GRanges}, one width-1 range per (credible set, grid +#' position), whose \code{mcols()} hold \code{cs, chrom, pos, effect, +#' lower, upper, halfwidth} -- \code{halfwidth} being +#' \code{(upper - lower) / 2}, the symmetric band half-width publication +#' tables carry (the collection method additionally carries the entry +#' identity columns). #' @seealso \code{\link{fsusieTraitEffects}}, #' \code{\link{fsusieAffectedRegions}} #' @examples @@ -2432,7 +2295,7 @@ setGeneric("fsusieCredibleBand", function(x, ...) { #' #' @param x A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. #' @param ... Ignored. -#' @return A long \code{tibble}: \code{cs, chrom, jointTrait, traitPos, +#' @return A long \code{DataFrame}: \code{cs, chrom, jointTrait, traitPos, #' effect} (the collection method additionally carries the entry identity #' columns). #' @seealso \code{\link{fsusieCredibleBand}}, @@ -2470,29 +2333,22 @@ setGeneric("fsusieAffectedRegions", function(x, ...) { # ============================================================================= # MethodParam accessor generics # ----------------------------------------------------------------------------- -# Only two Param classes carry accessors, and both earn them by being records -# the user HOLDS rather than builds and forgets: +# Every Param is read with `$` / `[[` and written with `$<-` (MethodParam.R), +# which rebuilds the record through its constructor. Two classes also carry +# named getters, because they are records the user HOLDS rather than builds +# and forgets: # # CredibleSetParam postprocessFinemappingFits() and buildTopLoci() take # an already-computed fit, so a stored fit is # re-summarized under changed settings without -# refitting. `L` / `Lgreedy` are deliberately -# get-only: they are seeded onto each SuSiE-family -# token's own arguments, so changing one needs a -# refit and a setter would hand back a record that -# looks applied but is not. -# GwasFineMappingParam the only Param nesting others. Once CredibleSetParam -# is settable, the container has to let the nested -# record back in, or it could be read but not written. -# -# The other 24 Params are construct-and-pass -- handed to one pipeline -# argument and never seen again -- and get none, which is what Bioconductor's -# own PileupParam does with twelve slots. +# refitting. `L` / `Lgreedy` are deliberately fixed: +# they are seeded onto each SuSiE-family token's own +# arguments, so changing one needs a refit, and `$<-` +# refuses them. +# GwasFineMappingParam the only Param nesting others. # -# get*/set* rather than Rsamtools' bamWhich()/bamWhich<-() spelling: pecotmr -# already exports 95 get* accessors, and bare field names are not available -# anyway -- `coverage` is an IRanges generic for read depth and `methods` is -# utils::methods. +# Bare field names are not available as getter names -- `coverage` is an +# IRanges generic for read depth and `methods` is utils::methods. # ============================================================================= #' @rdname CredibleSetParam @@ -2503,85 +2359,42 @@ setGeneric("csCoverage", function(x, ...) { standardGeneric("csCoverage") }) -#' @rdname CredibleSetParam -#' @param value The replacement value for that setting. -#' @export -setGeneric("csCoverage<-", function(x, ..., value) { - standardGeneric("csCoverage<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("secondaryCoverage", function(x, ...) { standardGeneric("secondaryCoverage") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("secondaryCoverage<-", function(x, ..., value) { - standardGeneric("secondaryCoverage<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("signalCutoff", function(x, ...) { standardGeneric("signalCutoff") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("signalCutoff<-", function(x, ..., value) { - standardGeneric("signalCutoff<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("minAbsCorr", function(x, ...) { standardGeneric("minAbsCorr") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("minAbsCorr<-", function(x, ..., value) { - standardGeneric("minAbsCorr<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("medianAbsCorr", function(x, ...) { standardGeneric("medianAbsCorr") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("medianAbsCorr<-", function(x, ..., value) { - standardGeneric("medianAbsCorr<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("includeAllCs", function(x, ...) { standardGeneric("includeAllCs") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("includeAllCs<-", function(x, ..., value) { - standardGeneric("includeAllCs<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("perCsColumns", function(x, ...) { standardGeneric("perCsColumns") }) -#' @rdname CredibleSetParam -#' @export -setGeneric("perCsColumns<-", function(x, ..., value) { - standardGeneric("perCsColumns<-") -}) - #' @rdname CredibleSetParam #' @export setGeneric("maxNumSingleEffects", function(x, ...) { @@ -2602,69 +2415,32 @@ setGeneric("fineMappingMethods", function(x, ...) { standardGeneric("fineMappingMethods") }) -#' @rdname GwasFineMappingParam -#' @param value The replacement value for that setting. -#' @export -setGeneric("fineMappingMethods<-", function(x, ..., value) { - standardGeneric("fineMappingMethods<-") -}) - #' @rdname GwasFineMappingParam #' @export setGeneric("credibleSetParam", function(x, ...) { standardGeneric("credibleSetParam") }) -#' @rdname GwasFineMappingParam -#' @export -setGeneric("credibleSetParam<-", function(x, ..., value) { - standardGeneric("credibleSetParam<-") -}) - #' @rdname GwasFineMappingParam #' @export setGeneric("susieRssParam", function(x, ...) { standardGeneric("susieRssParam") }) -#' @rdname GwasFineMappingParam -#' @export -setGeneric("susieRssParam<-", function(x, ..., value) { - standardGeneric("susieRssParam<-") -}) - #' @rdname GwasFineMappingParam #' @export setGeneric("panelFilterParam", function(x, ...) { standardGeneric("panelFilterParam") }) -#' @rdname GwasFineMappingParam -#' @export -setGeneric("panelFilterParam<-", function(x, ..., value) { - standardGeneric("panelFilterParam<-") -}) - #' @rdname GwasFineMappingParam #' @export setGeneric("initializeWithSusieInf", function(x, ...) { standardGeneric("initializeWithSusieInf") }) -#' @rdname GwasFineMappingParam -#' @export -setGeneric("initializeWithSusieInf<-", function(x, ..., value) { - standardGeneric("initializeWithSusieInf<-") -}) - #' @rdname GwasFineMappingParam #' @export setGeneric("fitRetention", function(x, ...) { standardGeneric("fitRetention") }) - -#' @rdname GwasFineMappingParam -#' @export -setGeneric("fitRetention<-", function(x, ..., value) { - standardGeneric("fitRetention<-") -}) diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index 3f066e34..ffaa5ac1 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -91,7 +91,7 @@ setMethod("show", "AnnotationMatrix", function(object) { .trim = FALSE )) cat(glue( - " Genome build: {GenomeInfoDb::genome(object)}\n", + " Genome build: {.showGenomeBuild(object)}\n", .trim = FALSE )) }) @@ -166,10 +166,11 @@ AnnotationMatrix <- function( "{length(snpRanges)} SNP range(s); the rows must match." )) } + ucsc <- .ucscRanges(snpRanges) named <- if (!is.null(genome) && length(genome) == 1L && !is.na(genome)) { - GenomeInfoDb::`genome<-`(snpRanges, value = genome) + GenomeInfoDb::`genome<-`(ucsc, value = genome) } else { - snpRanges + ucsc } se <- SummarizedExperiment::SummarizedExperiment( assays = list(annotations = annotations), @@ -183,9 +184,7 @@ AnnotationMatrix <- function( row.names = colnames(annotations) ) ) - obj <- methods::new("AnnotationMatrix", se) - validObject(obj) - obj + methods::new("AnnotationMatrix", se) } # ============================================================================= diff --git a/R/ColocBoostResult.R b/R/ColocBoostResult.R index 3db3f54a..3002a41a 100644 --- a/R/ColocBoostResult.R +++ b/R/ColocBoostResult.R @@ -21,10 +21,12 @@ # ("given these two colocalize, this is the shared causal variant"); vcp is # a marginal per-variant colocalization probability over the region. # -# What the two DO share is the LD panel they were computed against and the -# projection surface, so both extend ColocResultBase -- which carries the -# ldReference slot and its accessor -- and both answer colocPairs() and -# colocVariants(). +# What the two DO share is the projection surface, so both extend +# ColocResultBase and both answer colocPairs() and colocVariants(). Each keeps +# its own LD references. A colocboost run matches every summary-statistic +# outcome against its own row's reference, so this class keeps a named list of +# them -- each reference once -- and outcomeInfo records the one every outcome +# used. # # element the member variants of one CoS # inner mcols per-variant: vcp @@ -32,7 +34,8 @@ # CharacterList -- native variable arity), purity, cosNpc, # minNpcOutcome, topVariable, topVariableVcp, focalOutcome, # isColocalized -# slots ldReference, outcomeInfo, regionVcp, computingTime +# slots ldReference (a named list), outcomeInfo, regionVcp, +# computingTime # # Uncolocalized (outcome-specific) sets are elements too, flagged # isColocalized = FALSE, rather than living in a second container: they have @@ -46,11 +49,19 @@ NULL #' @description A collection of ColocBoost results, one element per confidence #' set (CoS). Project it with \code{\link{colocPairs}}, #' \code{\link{colocVariants}} or \code{\link{colocBoostOutcomes}}. +#' @slot ldReference A named list of the LD references the summary statistics +#' were matched against, each a genotype panel, a \code{GenotypeMixture} or +#' an \code{LdMatrix}, and each stored once however many outcomes used it. +#' Empty when no summary statistics were analysed. #' @slot outcomeInfo A data frame mapping each outcome \code{name} to its -#' \code{study}, \code{context}, \code{trait} and \code{dataForm}. ColocBoost -#' is given outcome names as bare labels, and those labels are lossy -- a -#' trait is context-qualified only when ambiguous -- so the mapping is -#' recorded when the names are minted rather than parsed back out later. +#' \code{study}, \code{context}, \code{trait}, \code{dataForm} and +#' \code{ldReference}, the name of the \code{ldReference} entry its +#' summary statistics were matched against (\code{NA} for an +#' individual-level outcome, whose LD comes from its own genotypes). +#' ColocBoost is given outcome names as bare labels, and those labels are +#' lossy -- a trait is context-qualified only when ambiguous -- so the +#' mapping is recorded when the names are minted rather than parsed back +#' out later. #' @slot regionVcp A \code{GRanges} of every variant in the analysed region #' carrying the marginal \code{vcp}. Collection-level: it spans the region, #' not the elements, so it cannot live in \code{mcols}. @@ -62,11 +73,13 @@ setClass( "ColocBoostResult", contains = "ColocResultBase", representation( + ldReference = "list", outcomeInfo = "data.frame", regionVcp = "ANY", computingTime = "list" ), prototype( + ldReference = list(), regionVcp = NULL, computingTime = list() ) @@ -108,33 +121,31 @@ methods::setValidity("ColocBoostResult", function(object) { } coll$push(.cbrCheckVcpColumn(object)) coll$push(.cbrCheckOutcomeInfo(object)) + # The outcomes, not the sets, are what match against a reference, so + # their keys live in outcomeInfo rather than in mcols. + coll$push(.ldRefDictProblems( + object@ldReference, + object@outcomeInfo$ldReference + )) coll$getMessages() } # The per-variant layer is the point of the class, exactly as SNP.PP.H4 is for -# ColocResult: an element without it reproduces the gap this closes. +# ColocResult: an element without it reproduces the gap this closes. The +# elements share one variant metadata table, so they all have the column or +# none does. # @noRd .cbrCheckVcpColumn <- function(object) { - if (length(object) == 0L) { - return(NULL) - } - bad <- which(!map_lgl(as.list(object), .cbrHasVcp)) - if (length(bad) == 0L) { + if (length(object) == 0L || .rtlHasVariantColumn(object, "vcp")) { return(NULL) } str_c( "element(s) ", - str_flatten(bad, ", "), + str_flatten(seq_along(object), ", "), " have no vcp column in their variant metadata" ) } -# @noRd -.cbrHasVcp <- function(g) { - md <- mcols(g, use.names = FALSE) - !is.null(md) && is_in("vcp", colnames(md)) -} - # Every outcome named on an element must be resolvable in outcomeInfo, or the # identity join silently drops rows -- which looks like "this CoS colocalized # fewer traits" rather than like a bookkeeping bug. @@ -188,6 +199,53 @@ setMethod("show", "ColocBoostResult", function(object) { invisible(NULL) }) +#' @rdname ldReference +#' @export +setMethod("ldReference", "ColocBoostResult", function(x) x@ldReference) + +# A ColocBoostResult keys its outcomes, not its sets, to its references, so +# its update is its own: the one reference an earlier version recorded was +# the one every summary-statistic outcome was matched against. A version +# older still recorded it as `ldSketch`. Each reference is brought up to date +# as any collection's is (.updateLdRefOrKeep()). +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "ColocBoostResult", + function(object, ..., verbose = FALSE) { + methods::callNextMethod( + .cbrUpdateLdRefs(object), + ..., + verbose = verbose + ) + } +) + +# @noRd +.cbrUpdateLdRefs <- function(object) { + object <- .renameSavedSlots(object, c(ldSketch = "ldReference")) + old <- methods::slot(object, "ldReference") + info <- .cbrWithLdKeys(object@outcomeInfo) + if (is.list(old) && !is.object(old)) { + refs <- map(old, .updateLdRefOrKeep) + } else { + dict <- .ldRefDict(list(.updateLdRefOrKeep(old))) + key <- if (length(dict$refs) == 0L) NA_character_ else dict$keys[[1L]] + info <- mutate( + info, + ldReference = if_else( + .data$dataForm == "sumstats", + key, + NA_character_ + ) + ) + refs <- dict$refs + } + updated <- `slot<-`(object, "ldReference", check = FALSE, value = refs) + `slot<-`(updated, "outcomeInfo", value = info) +} + # ---- construction ----------------------------------------------------------- #' @title Build a ColocBoostResult @@ -203,15 +261,22 @@ setMethod("show", "ColocBoostResult", function(object) { #' @param gwasStudy Optional character vector, parallel to \code{results}, #' 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 ldReference Optional genotype panel (see -#' \code{\link{readGenotypes}}). +#' \code{context}, \code{trait} and \code{dataForm}, and optionally to +#' \code{ldReference}, the name of the \code{ldReference} entry the +#' outcome's summary statistics were matched against. Without that column +#' every outcome gets \code{NA}. +#' @param ldReference Optional named list of the LD references the summary +#' statistics were matched against: genotype panels (see +#' \code{\link{readGenotypes}}), \code{GenotypeMixture} or \code{LdMatrix} +#' objects. #' @param computingTime Optional list of per-analysis timings. -#' @param includeUncolocalized Keep the outcome-specific (uncolocalized) sets -#' as elements flagged \code{isColocalized = FALSE}. Default \code{TRUE}: -#' dropping them at write time would make "no colocalization here" and "no -#' signal here" indistinguishable downstream. -#' @return A \code{ColocBoostResult}. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. +#' @return A \code{ColocBoostResult}. The outcome-specific (uncolocalized) +#' sets are kept as elements flagged \code{isColocalized = FALSE}, so "no +#' colocalization here" stays distinct from "no signal here"; +#' \code{x[x$isColocalized]} keeps the colocalized ones. #' @examples #' # Built from `colocboost` objects, which colocboostPipeline() supplies; #' # colocboostResultExample is one such result, from a real run. @@ -234,7 +299,7 @@ ColocBoostResult <- function( outcomeInfo = NULL, ldReference = NULL, computingTime = list(), - includeUncolocalized = TRUE + metadata = list() ) { results <- as.list(results) n <- length(results) @@ -248,35 +313,60 @@ ColocBoostResult <- function( .cbrRowsFor, results = results, analysis = analysis, - gwasStudy = gwasStudy, - includeUncolocalized = includeUncolocalized + gwasStudy = gwasStudy ) |> list_flatten() |> unname() - .cbrAssemble( + assembled <- .cbrAssemble( rows, - outcomeInfo = as.data.frame(outcomeInfo), + outcomeInfo = .cbrWithLdKeys(as.data.frame(outcomeInfo)), regionVcp = .cbrRegionVcp(results), - ldReference = .asLdRef(ldReference), + ldReference = .cbrAsLdRefList(ldReference), computingTime = computingTime ) + .withMetadata(assembled, metadata) +} + +# The `ldReference` argument as the slot holds it: an empty list for NULL, or +# the named list with each entry normalised like any LD-reference input (a +# bare GenotypeHandle becomes a panel). A lone reference is refused rather +# than given a made-up name, since the name is what outcomeInfo keys on. +# @noRd +.cbrAsLdRefList <- function(ldReference) { + if (is.null(ldReference)) { + return(list()) + } + if (!is.list(ldReference) || is.object(ldReference)) { + abort(str_c( + "`ldReference` must be NULL or a named list of LD references, ", + "e.g. list(qtl = panel)." + )) + } + map(ldReference, .asLdRef) +} + +# outcomeInfo with its `ldReference` column, NA throughout when the caller's +# frame has none: no recorded reference is not the same as a shared one. +# @noRd +.cbrWithLdKeys <- function(info) { + if (is_in("ldReference", colnames(info))) { + return(info) + } + mutate(info, ldReference = NA_character_) } # Every set (colocalized, then uncolocalized) of one colocboost object, as a # list of one-row records. # @noRd -.cbrRowsFor <- function(i, results, analysis, gwasStudy, includeUncolocalized) { +.cbrRowsFor <- function(i, results, analysis, gwasStudy) { res <- results[[i]] if (is.null(res)) { return(list()) } - out <- c( + c( .cbrColocalizedRows(res, analysis[[i]], gwasStudy[[i]]), - if (isTRUE(includeUncolocalized)) { - .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]]) - } + .cbrUncolocalizedRows(res, analysis[[i]], gwasStudy[[i]]) ) - out } # @noRd @@ -474,19 +564,17 @@ ColocBoostResult <- function( ) { elements <- map(rows, .cbrElementFor) grl <- S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(elements), + .rtlBindElements(elements), value = .cbrMcolsFor(rows) ) - obj <- new( + new( "ColocBoostResult", - grl, - ldReference = .asLdRef(ldReference), + .rtlNamed(grl), + ldReference = ldReference, outcomeInfo = outcomeInfo, regionVcp = regionVcp, computingTime = computingTime ) - validObject(obj) - obj } # @noRd @@ -551,7 +639,17 @@ ColocBoostResult <- function( #' @rdname colocViews #' @export -setMethod("colocPairs", "ColocBoostResult", function(x) { +setMethod( + "colocPairs", + "ColocBoostResult", + function(x) { + .asViewDataFrame(.cbrPairsTable(x = x)) + } +) + +# colocPairs() on a ColocBoostResult as a tibble. +# @noRd +.cbrPairsTable <- function(x) { # Named "pairs" for symmetry with ColocResult, but a ColocBoost row is a # SET, not a pair: `outcomes` holds however many outcomes colocalized. md <- mcols(x, use.names = FALSE) @@ -568,24 +666,35 @@ setMethod("colocPairs", "ColocBoostResult", function(x) { outcomes = map_chr(as.list(md$outcomes), str_flatten, collapse = "; "), nOutcomes = lengths(md$outcomes) ) -}) +} #' @rdname colocViews #' @export setMethod( "colocVariants", "ColocBoostResult", - function(x, pooled = FALSE) { + function(x) { + .withGenome(.variantTableGRanges(.cbrLongVariants(x)), .oneBuild(x)) + } +) + +#' @rdname colocViews +#' @export +setMethod( + "colocPooledVariants", + "ColocBoostResult", + function(x) { long <- .cbrLongVariants(x) - if (!isTRUE(pooled) || nrow(long) == 0L) { - return(long) + if (nrow(long) == 0L) { + return(.withGenome(.variantTableGRanges(long), .oneBuild(x))) } # Pooling across sets is noisy-OR only: unlike coloc, ColocBoost's sets # are not per-block slices of one signal, so there is no # mutually-exclusive sum stage to apply first. - long |> + pooledTbl <- long |> group_by(across(all_of(c("analysis", "variant_id")))) |> summarise(vcp = .crNoisyOr(.data$vcp), .groups = "drop") + .withGenome(.variantTableGRanges(pooledTbl), .oneBuild(x)) } ) @@ -619,9 +728,12 @@ setMethod( #' label back, never the study / context / trait behind it. #' @param x A \code{\linkS4class{ColocBoostResult}}. #' @param ... Ignored. -#' @return A tibble with one row per (set, outcome) and the set-level columns -#' repeated, plus \code{outcome}, \code{study}, \code{context}, -#' \code{trait} and \code{dataForm}. +#' @return A \code{DataFrame} with one row per (set, outcome), the +#' set-level columns repeated, plus \code{outcome}, \code{study}, +#' \code{context}, +#' \code{trait}, \code{dataForm} and \code{ldReference} (the name of the +#' \code{\link{ldReference}} entry the outcome's summary statistics were +#' matched against). #' @examples #' # See colocboostPipeline(); a ColocBoostResult carries the mapping it needs. #' methods::existsMethod("colocBoostOutcomes", "ColocBoostResult") @@ -632,7 +744,17 @@ setGeneric("colocBoostOutcomes", function(x, ...) { #' @rdname colocBoostOutcomes #' @export -setMethod("colocBoostOutcomes", "ColocBoostResult", function(x) { +setMethod( + "colocBoostOutcomes", + "ColocBoostResult", + function(x) { + .asViewDataFrame(.cbrOutcomesTable(x = x)) + } +) + +# colocBoostOutcomes() as a tibble. +# @noRd +.cbrOutcomesTable <- function(x) { if (length(x) == 0L) { return(tibble()) } @@ -656,35 +778,18 @@ setMethod("colocBoostOutcomes", "ColocBoostResult", function(x) { as_tibble(info, .name_repair = "minimal"), by = c(outcome = "name") ) -}) - -# ---- coercion --------------------------------------------------------------- - -#' @title Coerce a ColocBoostResult to a data frame -#' @description Returns the set-level view. New code should call the view it -#' wants (\code{\link{colocViews}}, -#' \code{\link{colocBoostOutcomes}}). -#' @param x A \code{ColocBoostResult}. -#' @param row.names,optional Ignored; present for generic compatibility. -#' @param ... Ignored. -#' @return A data frame with one row per confidence set. -#' @examples -#' methods::existsMethod("as.data.frame", "ColocBoostResult") -#' @export -setMethod( - "as.data.frame", - "ColocBoostResult", - function(x, row.names = NULL, optional = FALSE, ...) { - as.data.frame(colocPairs(x)) - } -) +} #' @title Per-Analysis Timings #' @description The wall-clock timings colocboostPipeline recorded for each #' analysis it ran. #' @param x A \code{\linkS4class{ColocBoostResult}}. #' @param ... Ignored. -#' @return A list of timings, empty when none were recorded. +#' @return A \code{DataFrame}, one row per analysis that ran: +#' \code{analysis} (\code{xqtl_coloc}, \code{joint_gwas} or +#' \code{separate_gwas}), \code{nRuns} (1, or one per GWAS study for +#' \code{separate_gwas}) and \code{seconds}, their total wall-clock time. +#' No rows when none were recorded. #' @examples #' methods::existsMethod("computingTime", "ColocBoostResult") #' @export @@ -695,9 +800,38 @@ setGeneric("computingTime", function(x, ...) { #' @rdname computingTime #' @export setMethod("computingTime", "ColocBoostResult", function(x) { - x@computingTime + .cbrTimingTable(x@computingTime) }) +# The recorded timings, one row per analysis that ran. +# @noRd +.cbrTimingTable <- function(timing) { + runs <- compact(timing$Analysis %||% list()) + S4Vectors::DataFrame( + analysis = names(runs) %||% character(0), + nRuns = map_int(unname(runs), .cbrTimingRuns), + seconds = map_dbl(unname(runs), .cbrTimingSeconds) + ) +} + +# A per-study sweep records its run count; every other analysis is one run. +# @noRd +.cbrTimingRuns <- function(t) { + if (is.list(t)) as.integer(t$n_studies %||% NA_integer_) else 1L +} + +# @noRd +.cbrTimingSeconds <- function(t) { + total <- if (is.list(t)) t$total else t + if (is.null(total)) { + return(NA_real_) + } + if (inherits(total, "difftime")) { + return(as.numeric(total, units = "secs")) + } + as.numeric(total) +} + #' @title Region-Wide Variant Colocalization Probabilities #' @description The marginal \code{vcp} for every variant in the analysed #' region, not just the confidence-set members. Distinct from diff --git a/R/ColocResult.R b/R/ColocResult.R index 08188b43..e049616d 100644 --- a/R/ColocResult.R +++ b/R/ColocResult.R @@ -46,33 +46,37 @@ 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 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(ldReference = "LdReference_OR_NULL"), - prototype(ldReference = NULL) -) - -#' @rdname ldReference +#' +#' Each subclass carries its own LD reference, and both answer +#' \code{\link{ldReference}}: a \code{ColocResult} holds the one reference +#' its pairs were computed against, a \code{ColocBoostResult} one per +#' reference its summary statistics were matched against. #' @export -setMethod("ldReference", "ColocResultBase", function(x) x@ldReference) +setClass("ColocResultBase", contains = c("VIRTUAL", "RangedTupleList")) #' @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{ldReference} is what -#' \code{colocCredibleSets()} uses to compute credible-set purity. +#' @details The \code{ldReference} is what \code{colocCredibleSets()} uses to +#' compute credible-set purity, each pair's from its own reference. +#' @slot ldReference A named list of the LD references the pairs were computed +#' against, each a genotype panel, a \code{GenotypeMixture} or an +#' \code{LdMatrix}, stored once apiece; the \code{ldReference} column of +#' \code{mcols} names the entry each pair used (\code{NA} for none). #' @seealso \code{\link{colocPipeline}} #' @export -setClass("ColocResult", contains = "ColocResultBase") +setClass( + "ColocResult", + contains = "ColocResultBase", + representation(ldReference = "list"), + prototype(ldReference = list()) +) + +#' @rdname ldReference +#' @export +setMethod("ldReference", "ColocResult", function(x) .ldRefsInUse(x)) methods::setValidity("ColocResult", function(object) { .validateColocResult(object) @@ -94,6 +98,7 @@ methods::setValidity("ColocResult", function(object) { if (!coll$isEmpty()) { return(coll$getMessages()) } + coll$push(.ldRefDictProblems(object@ldReference, .ldRefKeys(object))) coll$push(.crCheckPpColumns(object)) coll$push(.crCheckVariantColumn(object)) coll$getMessages() @@ -139,29 +144,20 @@ methods::setValidity("ColocResult", function(object) { # The per-variant layer is the whole point of the class, so an element without # it is rejected rather than tolerated -- a silently absent SNP.PP.H4 would -# reproduce the exact gap this class exists to close. +# reproduce the exact gap this class exists to close. The elements share one +# variant metadata table, so they all have the column or none does. # @noRd .crCheckVariantColumn <- function(object) { - if (length(object) == 0L) { - return(NULL) - } - bad <- which(!map_lgl(as.list(object), .crHasSnpPp)) - if (length(bad) == 0L) { + if (length(object) == 0L || .rtlHasVariantColumn(object, "SNP.PP.H4")) { return(NULL) } str_c( "element(s) ", - str_flatten(bad, ", "), + str_flatten(seq_along(object), ", "), " have no SNP.PP.H4 column in their variant metadata" ) } -# @noRd -.crHasSnpPp <- function(g) { - md <- mcols(g, use.names = FALSE) - !is.null(md) && is_in("SNP.PP.H4", colnames(md)) -} - # ---- accessors -------------------------------------------------------------- #' @rdname show-methods @@ -198,9 +194,14 @@ 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 ldReference Optional genotype panel (see \code{\link{readGenotypes}}) -#' for the LD reference, used by \code{\link{colocCredibleSets}} to -#' compute purity. +#' @param ldReference Optional LD reference -- a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +#' \code{LdMatrix} -- for every pair, or a list with one per pair; used by +#' \code{\link{colocCredibleSets}} to compute purity. Each distinct +#' reference is stored once. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{ColocResult}. #' @examples #' pairs <- data.frame( @@ -218,7 +219,12 @@ setMethod("show", "ColocResult", function(object) { #' )) #' ColocResult(pairs, variants) #' @export -ColocResult <- function(pairs, variants, ldReference = NULL) { +ColocResult <- function( + pairs, + variants, + ldReference = NULL, + metadata = list() +) { pairs <- as.data.frame(pairs, stringsAsFactors = FALSE) if (!is.list(variants) || length(variants) != nrow(pairs)) { msg <- glue( @@ -228,19 +234,20 @@ ColocResult <- function(pairs, variants, ldReference = NULL) { abort(msg) } elements <- map(variants, .crVariantsToGRanges) + dict <- .ldRefDict(.ldRefPerTuple(ldReference, nrow(pairs))) # Set unconditionally, including at zero rows: an empty result still has to # carry the column schema, or it fails validity and a caller reading # `result$PP.H4.abf` gets NULL exactly when there is nothing to report. + cols <- list_assign(as.list(pairs), ldReference = dict$keys) grl <- S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(elements), + .rtlBindElements(elements), value = exec( S4Vectors::DataFrame, - !!!c(as.list(pairs), list(check.names = FALSE)) + !!!c(cols, list(check.names = FALSE)) ) ) - obj <- new("ColocResult", grl, ldReference = .asLdRef(ldReference)) - validObject(obj) - obj + obj <- new("ColocResult", .rtlNamed(grl), ldReference = dict$refs) + .withMetadata(obj, metadata) } # One pair's variant table -> a GRanges carrying SNP.PP.H4 in its mcols. @@ -332,22 +339,38 @@ ColocResult <- function(pairs, variants, ldReference = NULL) { #' @rdname colocViews #' @export -setMethod("colocPairs", "ColocResult", function(x) { +setMethod( + "colocPairs", + "ColocResult", + function(x) { + .asViewDataFrame(.crPairsTable(x = x)) + } +) + +# colocPairs() as a tibble, for the views built on it. +# @noRd +.crPairsTable <- function(x) { md <- mcols(x, use.names = FALSE) if (is.null(md) || length(x) == 0L) { return(tibble()) } as_tibble(as.data.frame(md), .name_repair = "minimal") +} + +#' @rdname colocViews +#' @export +setMethod("colocVariants", "ColocResult", function(x) { + # Ranged, placed by each row's variant id, so the view narrows with + # subsetByOverlaps(). + .withGenome(.variantTableGRanges(.crLongVariants(x)), .oneBuild(x)) }) #' @rdname colocViews #' @export -setMethod("colocVariants", "ColocResult", function(x, pooled = FALSE) { +setMethod("colocPooledVariants", "ColocResult", function(x) { long <- .crLongVariants(x) - if (!isTRUE(pooled) || nrow(long) == 0L) { - return(long) - } - .crPoolVariants(long) + pooled <- if (nrow(long) == 0L) long else .crPoolVariants(long) + .withGenome(.variantTableGRanges(pooled), .oneBuild(x)) }) # One row per (pair, variant): the pair's metadata repeated across its @@ -411,8 +434,18 @@ setMethod("colocVariants", "ColocResult", function(x, pooled = FALSE) { #' @rdname colocViews #' @export -setMethod("colocGenes", "ColocResult", function(x) { - pairs <- colocPairs(x) +setMethod( + "colocGenes", + "ColocResult", + function(x) { + .asViewDataFrame(.crGenesTable(x = x)) + } +) + +# colocGenes() as a tibble. +# @noRd +.crGenesTable <- function(x) { + pairs <- .crPairsTable(x) if (nrow(pairs) == 0L) { return(tibble()) } @@ -433,7 +466,7 @@ setMethod("colocGenes", "ColocResult", function(x) { nPairs = sum(.data$nPairs), .groups = "drop" ) -}) +} # ---- credible-set view ------------------------------------------------------ @@ -449,25 +482,82 @@ setMethod( minAbsCorr = 0.8, requireMaxH4 = FALSE ) { - keep <- .crPairFilter(x, minPp4, requireMaxH4) - if (length(keep) == 0L) { - return(tibble()) - } - # Filtering happens BEFORE any LD work, so a stricter threshold costs - # strictly less -- which is the reason purity lives on the accessor - # rather than being precomputed at construction. - sets <- compact(map(keep, .crCsForPair, x = x, coverage = coverage)) - if (length(sets) == 0L) { - return(tibble()) - } - out <- bind_rows(sets) - .crApplyPurityFilter( - mutate(out, purity = .crPuritiesFor(out, ldReference(x))), - minAbsCorr + sets <- .crCredibleSets( + x = x, + coverage = coverage, + minPp4 = minPp4, + minAbsCorr = minAbsCorr, + requireMaxH4 = requireMaxH4 ) + .withGenome(.crSetsAsList(sets), .oneBuild(x)) } ) +# The coloc credible sets: one record per set, its members' ranges and its +# set-level row, filtered on the pair and then on purity. +# @noRd +.crCredibleSets <- function( + x, + coverage = 0.95, + minPp4 = NULL, + minAbsCorr = 0.8, + requireMaxH4 = FALSE +) { + pairs <- .crPairFilter(x, minPp4, requireMaxH4) + # Filtering happens BEFORE any LD work, so a stricter threshold costs + # strictly less -- which is the reason purity lives on the accessor + # rather than being precomputed at construction. + sets <- compact(map(pairs, .crCsForPair, x = x, coverage = coverage)) + if (length(sets) == 0L) { + return(list()) + } + purity <- map_dbl(sets, .crSetPurity, refs = ldReference(x)) + sets <- map2(sets, purity, .crWithPurity) + if (is.null(minAbsCorr)) { + return(sets) + } + # An unmeasurable purity does not drop a set: with no LD reference there is + # no evidence the set is impure, and silently discarding it would make the + # view depend on whether a sketch happened to be attached. + keep(sets, .crPureEnough, minAbsCorr = minAbsCorr) +} + +# The sets as one GRangesList: each set's members its element, its set-level +# columns that element's mcols. +# @noRd +.crSetsAsList <- function(sets) { + if (length(sets) == 0L) { + return(GenomicRanges::GRangesList()) + } + S4Vectors::`mcols<-`( + .rtlBindElements(map(sets, "members")), + value = S4Vectors::DataFrame( + bind_rows(map(sets, "row")), + check.names = FALSE + ) + ) +} + +# Purity of one set: the minimum absolute correlation among its members, one +# LD extraction per set (section 3.7), against its own pair's reference. NA +# when the pair has no LD reference to extract from -- reported honestly +# rather than defaulted to a passing value. +# @noRd +.crSetPurity <- function(set, refs) { + .crPurityOne(.grVariantIds(set$members), set$row$ldReference, refs) +} + +# @noRd +.crWithPurity <- function(set, purity) { + list_assign(set, row = mutate(set$row, purity = purity)) +} + +# @noRd +.crPureEnough <- function(set, minAbsCorr) { + p <- set$row$purity + is.na(p) || p >= minAbsCorr +} + # Which pairs survive the pair-level filters. Both conditions read columns # already stored on the pair, so neither costs anything to evaluate. # @noRd @@ -510,13 +600,15 @@ setMethod( members <- ord[seq_len(nKeep)] ids <- .grVariantIds(g[members]) md <- as.data.frame(mcols(x, use.names = FALSE))[i, , drop = FALSE] - mutate( - as_tibble(md, .name_repair = "minimal"), - csSize = length(members), - csCoverage = cum[[nKeep]], - leadVariant = ids[[1L]], - leadPp = pp[ord][[1L]], - csVariants = list(ids) + list( + members = g[members], + row = mutate( + as_tibble(md, .name_repair = "minimal"), + csSize = length(members), + csCoverage = cum[[nKeep]], + leadVariant = ids[[1L]], + leadPp = pp[ord][[1L]] + ) ) } @@ -532,20 +624,13 @@ setMethod( if (length(hit) == 0L) length(cum) else hit[[1L]] } -# Purity per credible set: the minimum absolute correlation among its members, -# 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, ldReference) { +#' @importFrom rlang try_fetch +.crPurityOne <- function(ids, key, refs) { + ldReference <- .ldRefForKey(key, refs) if (is.null(ldReference)) { - return(rep(NA_real_, nrow(out))) + return(NA_real_) } - map_dbl(out$csVariants, .crPurityOne, ldReference = ldReference) -} - -# @noRd -#' @importFrom rlang try_fetch -.crPurityOne <- function(ids, ldReference) { # A singleton set has no pair to correlate, and susie treats it as pure. if (length(ids) < 2L) { return(1) @@ -564,50 +649,3 @@ setMethod( } min(abs(ld[upper.tri(ld)])) } - -# @noRd -.crApplyPurityFilter <- function(out, minAbsCorr) { - if (is.null(minAbsCorr)) { - return(out) - } - # An unmeasurable purity does not drop a set: with no LD reference there is - # no evidence the set is impure, and silently discarding it would make the - # view depend on whether a sketch happened to be attached. - keep <- is.na(out$purity) | out$purity >= minAbsCorr - out[keep, , drop = FALSE] -} - -# ---- coercion --------------------------------------------------------------- - -#' @title Coerce a ColocResult to a data frame -#' @description Returns the pair-level view, which is the flat table -#' \code{colocPipeline()} used to return directly. Provided so existing -#' consumers keep working; new code should call the view it actually wants -#' (see \code{\link{colocViews}}). -#' @param x A \code{ColocResult}. -#' @param row.names,optional Ignored; present for generic compatibility. -#' @param ... Ignored. -#' @return A data frame with one row per tested pair. -#' @examples -#' pairs <- data.frame( -#' study = "s1", context = "c1", trait = "g1", method = "susie", -#' gwasStudy = "G1", gwasContext = NA_character_, -#' gwasTrait = NA_character_, gwasMethod = "susie", -#' blockId = "chr1_1_1000", -#' qtlCs = 1L, gwasCs = 1L, nSnps = 2L, -#' PP.H0.abf = 0.1, PP.H1.abf = 0.1, PP.H2.abf = 0.1, -#' PP.H3.abf = 0.1, PP.H4.abf = 0.6 -#' ) -#' variants <- list(data.frame( -#' variant_id = c("chr1:100:A:G", "chr1:200:C:T"), -#' SNP.PP.H4 = c(0.7, 0.3) -#' )) -#' as.data.frame(ColocResult(pairs, variants)) -#' @export -setMethod( - "as.data.frame", - "ColocResult", - function(x, row.names = NULL, optional = FALSE, ...) { - as.data.frame(colocPairs(x)) - } -) diff --git a/R/CtwasResult.R b/R/CtwasResult.R index cbe7b156..c691fe46 100644 --- a/R/CtwasResult.R +++ b/R/CtwasResult.R @@ -1,48 +1,72 @@ # ============================================================================= # CtwasResult S4 class # ----------------------------------------------------------------------------- -# DFrame-subclass collection of cTWAS runs, keyed by the identity tuple -# (gwasStudy, study, context, method). Each row holds a CtwasResultEntry -# payload (fine-mapping posteriors + group priors + region metadata) for one -# run. Unlike the QTL family, `trait` is NOT a key -- cTWAS is multi-gene per -# run, so genes live inside the payload. Optional joint columns (jointStudies, +# RangedTupleList collection of cTWAS runs. A run is keyed by the identity +# tuple (gwasStudy, study, context, method) and, as a genome-wide GWAS fit is +# in a GwasFineMappingResult, split into one element per cTWAS region: the +# element holds that region's gene (and, with keepSnps, SNP) posteriors as +# ranges, and mcols carry the run identity, the region (`blockId`, cTWAS's +# region_id), the region's per-effect susie alpha table (`susieAlpha`), its +# region metadata (`regionInfo`) and the run's jointly-estimated group priors +# (`groupPriors`, repeated on each of the run's rows, as a GWAS fit's +# settings repeat on its blocks). +# +# Unlike the QTL family, `trait` is NOT a key -- cTWAS is multi-gene per run, +# so genes live inside the elements. 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 / # FineMappingResultBase families. # ============================================================================= -#' @include AllGenerics.R tupleSelectors.R +#' @include AllGenerics.R tupleSelectors.R RangedTupleList.R CtwasResultEntry.R NULL #' @title cTWAS Result Collection -#' @description S4 collection of cTWAS runs keyed by the identity tuple -#' \code{(gwasStudy, study, context, method)}. Each row holds a -#' \code{\linkS4class{CtwasResultEntry}} payload -- fine-mapping posteriors, -#' the jointly-estimated group priors, and region metadata -- for one run. +#' @description S4 collection of cTWAS runs, each keyed by the identity tuple +#' \code{(gwasStudy, study, context, method)} and split into one element per +#' cTWAS region, the way a \code{\linkS4class{GwasFineMappingResult}} holds +#' a genome-wide fit as one element per LD block. An element is a +#' \code{GRanges} of that region's gene (and, with \code{keepSnps}, SNP) +#' posteriors; \code{mcols()} carry the run identity, the region +#' (\code{blockId}), the region's per-effect susie alpha table +#' (\code{susieAlpha}), its region metadata (\code{regionInfo}) and the +#' run's jointly-estimated group priors (\code{groupPriors}), which repeat +#' on each of the run's rows. #' @details Unlike the QTL family, \code{trait} is not part of the key: a cTWAS -#' run is multi-gene, so genes live inside the payload. The optional +#' run is multi-gene, so genes live inside the elements. The optional #' \code{jointStudies} / \code{jointContexts} columns tag rows born from a #' multi-study or multi-context run and participate in the uniqueness key, #' exactly as in the \code{\linkS4class{TwasWeights}} and fine-mapping -#' families. +#' families. \code{\link{ctwasPosteriors}} and \code{\link{susieAlpha}} +#' stack every region back into one \code{GRanges}. #' @seealso \code{\link{CtwasResult}} for the constructor and #' \code{\link{ctwasPipeline}} for the pipeline that builds one. #' @export -setClass("CtwasResult", contains = "DFrame", validity = function(object) { - .validateCtwasResult(object) -}) +setClass( + "CtwasResult", + contains = "RangedTupleList", + validity = function(object) .validateCtwasResult(object) +) + +# The run identity every row carries, and the per-region payload columns. +# @noRd +.CTWAS_ID_COLS <- c("gwasStudy", "study", "context", "method") + +# @noRd +.CTWAS_PAYLOAD_COLS <- c("susieAlpha", "regionInfo", "groupPriors") # ---- CtwasResult validity helpers ------------------------------------------ -# Collect all contract violations (empty vector = valid). Entry checks run only -# once the required columns are present. +# Collect all contract violations (TRUE when there are none). The identity and +# uniqueness checks run only once the required columns are present. # @noRd #' @importFrom checkmate makeAssertCollection assertNames .validateCtwasResult <- function(object) { + cols <- colnames(mcols(object, use.names = FALSE)) coll <- makeAssertCollection() assertNames( - names(object), - must.include = c("gwasStudy", "study", "context", "method", "entry"), + cols, + must.include = c(.CTWAS_ID_COLS, "blockId", .CTWAS_PAYLOAD_COLS), what = "colnames", .var.name = "columns", add = coll @@ -52,40 +76,12 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { if (!coll$isEmpty()) { return(coll$getMessages()) } - coll$push(.ctwasResCheckEntries(object)) - coll$getMessages() -} - -# @noRd -.ctwasResCheckEntries <- function(object) { - jointCols <- intersect(c("jointStudies", "jointContexts"), names(object)) - c( - .ctwasResCheckEntryLength(object), - .ctwasResCheckEntryTypes(object), + jointCols <- intersect(c("jointStudies", "jointContexts"), cols) + problems <- c( .ctwasResCheckJointCols(object, jointCols), .ctwasResCheckTupleUniqueness(object, jointCols) ) -} - -# @noRd -.ctwasResCheckEntryLength <- function(object) { - if (length(object$entry) != nrow(object)) { - return("length(entry) must equal nrow(.) for CtwasResult") - } - NULL -} - -# @noRd -.ctwasResCheckEntryTypes <- function(object) { - if (!all(map_lgl(object$entry, .ctwasResIsEntry))) { - return("every element of the `entry` column must be a CtwasResultEntry") - } - NULL -} - -# @noRd -.ctwasResIsEntry <- function(e) { - methods::is(e, "CtwasResultEntry") + if (length(problems) == 0L) TRUE else problems } # @noRd @@ -95,24 +91,26 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # @noRd .ctwasResJointColError <- function(jc, object) { - if (!is.character(object[[jc]])) { + value <- .ctwasResColOf(jc, object) + if (!is.character(value)) { return(glue( - "'{jc}' column must be character (got {class(object[[jc]])[[1L]]})" + "'{jc}' column must be character (got {class(value)[[1L]]})" )) } NULL } +# One row per (run, region): the region joins the run identity in the key. # @noRd .ctwasResCheckTupleUniqueness <- function(object, jointCols) { - keyCols <- c("gwasStudy", "study", "context", "method", jointCols) + keyCols <- c(.CTWAS_ID_COLS, jointCols, "blockId") keyTbl <- as_tibble(set_names( map(keyCols, .ctwasResColOf, object = object), keyCols )) if (nrow(distinct(keyTbl)) < nrow(keyTbl)) { return(str_c( - "(gwasStudy, study, context, method[, joint*]) ", + "(gwasStudy, study, context, method[, joint*], region) ", "tuple uniqueness violated" )) } @@ -121,10 +119,10 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { # @noRd .ctwasResColOf <- function(cn, object) { - object[[cn]] + mcols(object, use.names = FALSE)[[cn]] } -# Each joint-provenance column must be one value per row. +# Each joint-provenance column must be one value per run. # @noRd .ctwasCheckJointColLength <- function(nm, val, n) { if (length(val) == n) { @@ -135,28 +133,41 @@ setClass("CtwasResult", contains = "DFrame", validity = function(object) { } #' @title Create a CtwasResult Collection -#' @description Construct a \code{CtwasResult} DFrame-subclass collection of -#' cTWAS runs from per-tuple vectors and a list of -#' \code{\link{CtwasResultEntry}} payloads (one per run). A single-context run -#' is one row; a multi-context run emits per-context rows sharing the same -#' \code{jointContexts} set and jointly-estimated group priors. +#' @description Construct a \code{CtwasResult} collection of cTWAS runs from +#' per-run identity vectors and a list of \code{\link{CtwasResultEntry}} +#' payloads (one per run). Each run is split into one element per cTWAS +#' region -- by the payloads' \code{region_id}, or by chromosome when they +#' carry none -- so a single-context run is one row per region, and a +#' multi-context run emits per-context rows sharing the same +#' \code{jointContexts} set and jointly-estimated group priors. A run whose +#' payload holds no posteriors is kept as one empty element. #' @param gwasStudy Character vector of GWAS (disease) study identifiers. #' @param studyName Character vector of QTL study identifiers. -#' @param context Character vector of context labels (scalar per row). +#' @param context Character vector of context labels (scalar per run). #' @param method Character vector of weight-method names. -#' @param entry List / \code{SimpleList} of \code{CtwasResultEntry} objects. +#' @param entry List / \code{SimpleList} of \code{CtwasResultEntry} objects, +#' one per run; their posteriors and susie alpha tables must be +#' \code{GRanges}, which the pipeline builds them as. #' @param jointStudies Optional character vector (length #' \code{length(gwasStudy)}) listing the joined studies for a multi-study run, #' \code{NA_character_} otherwise. \code{NULL} (default) omits the column. #' @param jointContexts Optional character vector for multi-context runs. Same #' shape as \code{jointStudies}. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{CtwasResult} object. #' @examples +#' at <- IRanges::IRanges(c(100L, 200L), width = 1L) #' cre <- CtwasResultEntry( -#' posteriors = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), -#' susieAlpha = data.frame(id = c("g1", "g2"), alpha = c(0.9, 0.1))) -#' cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", context = "brain", -#' method = "susie", entry = list(cre)) +#' posteriors = GenomicRanges::GRanges("chr1", at, +#' id = c("g1", "g2"), region_id = "chr1_1_1000", +#' susie_pip = c(0.9, 0.1)), +#' susieAlpha = GenomicRanges::GRanges("chr1", at, +#' id = c("g1", "g2"), region_id = "chr1_1_1000", +#' susie_alpha = c(0.9, 0.1))) +#' cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", +#' context = "brain", method = "susie", entry = list(cre)) #' cr #' @export CtwasResult <- function( @@ -166,44 +177,207 @@ CtwasResult <- function( method, entry, jointStudies = NULL, - jointContexts = NULL + jointContexts = NULL, + metadata = list() ) { n <- length(gwasStudy) - if ( - length(studyName) != n || - length(context) != n || - length(method) != n || - length(entry) != n - ) { - msg <- glue( - "`gwasStudy`, `study`, `context`, `method`, and `entry` must all ", - "have the same length." - ) - abort(msg) - } - cols <- list( - gwasStudy = as.character(gwasStudy), - study = as.character(studyName), - context = as.character(context), - method = as.character(method), - entry = S4Vectors::SimpleList(entry) - ) + .ctwasCheckRunLengths(n, studyName, context, method, entry) supplied <- compact(list( jointStudies = jointStudies, jointContexts = jointContexts )) walk2(names(supplied), supplied, .ctwasCheckJointColLength, n = n) - dfArgs <- c( - cols, - map(supplied, as.character), - list(check.names = FALSE) + entries <- as.list(entry) + walk(seq_along(entries), .ctwasAssertEntry, entries = entries) + identity <- exec( + S4Vectors::DataFrame, + !!!c( + list( + gwasStudy = as.character(gwasStudy), + study = as.character(studyName), + context = as.character(context), + method = as.character(method) + ), + map(supplied, as.character), + list(check.names = FALSE) + ) + ) + .withMetadata( + .ctwasNewResult(identity, map(entries, .ctwasSplitRun)), + metadata ) - df <- exec(S4Vectors::DataFrame, !!!dfArgs) - obj <- new("CtwasResult", df) - validObject(obj) - obj } +# @noRd +.ctwasCheckRunLengths <- function(n, studyName, context, method, entry) { + if ( + length(studyName) == n && + length(context) == n && + length(method) == n && + length(entry) == n + ) { + return(invisible(NULL)) + } + abort(str_c( + "`gwasStudy`, `studyName`, `context`, `method`, and `entry` must ", + "all have the same length." + )) +} + +# A run's payload must be a CtwasResultEntry whose posteriors and susie alpha +# table, when present, are ranges: an element is a GRanges, so a table whose +# ids carry no position has nowhere to go and is refused rather than dropped. +# @noRd +.ctwasAssertEntry <- function(i, entries) { + e <- entries[[i]] + if (!methods::is(e, "CtwasResultEntry")) { + abort(glue( + "CtwasResult: run {i}'s payload must be a CtwasResultEntry ", + "(got {class(e)[[1L]]})." + )) + } + parts <- list(posteriors = e@posteriors, susieAlpha = e@susieAlpha) + tables <- names(parts)[!map_lgl(parts, .ctwasIsRangedOrEmpty)] + if (length(tables) > 0L) { + abort(glue( + "CtwasResult: run {i}'s {str_flatten(tables, ' and ')} carry no ", + "genomic coordinates, so they cannot be placed in a ranged ", + "collection. Build them as GRanges." + )) + } + invisible(NULL) +} + +# @noRd +.ctwasIsRangedOrEmpty <- function(x) { + is.null(x) || methods::is(x, "GRanges") +} + +# ---- splitting a run into its regions --------------------------------------- + +# One run's per-region pieces: the region ids, and for each region its +# posteriors (the element), susie alpha table and region metadata. A run with +# no posteriors at all is one empty region, so it still shows up as a row. +# @noRd +.ctwasSplitRun <- function(e) { + post <- e@posteriors %||% GenomicRanges::GRanges() + sa <- e@susieAlpha %||% GenomicRanges::GRanges() + regions <- unique(c(.ctwasRegionKeys(post), .ctwasRegionKeys(sa))) + if (length(regions) == 0L) { + regions <- NA_character_ + } + list( + blockId = regions, + elements = map(regions, .ctwasRegionSlice, gr = post), + susieAlpha = map(regions, .ctwasRegionSlice, gr = sa), + regionInfo = map(regions, .ctwasRegionInfoSlice, ri = e@regionInfo), + groupPriors = rep(list(e@groupPriors), length(regions)) + ) +} + +# Which region each range belongs to: cTWAS's region_id, or, for a payload +# built without one, the chromosome it sits on. +# @noRd +.ctwasRegionKeys <- function(gr) { + if (is_in("region_id", colnames(mcols(gr)))) { + return(as.character(mcols(gr)$region_id)) + } + as.character(seqnames(gr)) +} + +# @noRd +.ctwasRegionSlice <- function(region, gr) { + if (is.na(region)) { + return(gr[0L]) + } + gr[.ctwasRegionKeys(gr) == region] +} + +# The region's own metadata row, or the run's table as given when it is not +# keyed by region_id. +# @noRd +.ctwasRegionInfoSlice <- function(region, ri) { + table <- .ctwasRegionInfoTable(ri) + if ( + is.null(table) || !is_in("region_id", colnames(table)) || is.na(region) + ) { + return(ri) + } + hit <- as.character(table$region_id) == region + if (methods::is(ri, "GRanges")) { + return(ri[hit]) + } + ri[hit, , drop = FALSE] +} + +# Region metadata's columns, whichever form it was built in. +# @noRd +.ctwasRegionInfoTable <- function(ri) { + if (methods::is(ri, "GRanges")) mcols(ri) else ri +} + +# Every run's regions as one collection: the run identity repeated across +# its regions, the region's payload columns beside it. +# @noRd +.ctwasNewResult <- function(identity, runs) { + reps <- rep(seq_along(runs), map_int(runs, .ctwasRunSize)) + pieces <- c("susieAlpha", "regionInfo", "groupPriors") + payload <- set_names(map(pieces, .ctwasPayloadColumn, runs = runs), pieces) + md <- cbind( + identity[reps, , drop = FALSE], + exec( + S4Vectors::DataFrame, + !!!c( + list(blockId = list_c(map(runs, "blockId")) %||% character(0)), + payload, + list(check.names = FALSE) + ) + ) + ) + elements <- list_flatten(map(runs, "elements")) + grl <- S4Vectors::`mcols<-`(.rtlBindElements(unname(elements)), value = md) + new("CtwasResult", .rtlNamed(grl)) +} + +# @noRd +.ctwasRunSize <- function(run) { + length(run$blockId) +} + +# @noRd +.ctwasPayloadColumn <- function(piece, runs) { + S4Vectors::SimpleList(list_flatten(map(runs, piece))) +} + +# Before it held one element per region, a CtwasResult was a DFrame of whole +# runs, one CtwasResultEntry per row in an `entry` column; an object saved +# then still carries that table as its `listData` attribute. It is rebuilt +# through the constructor, which splits each run into its regions. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "CtwasResult", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'CtwasResult')") + } + old <- attr(object, "listData", exact = TRUE) + if (is.null(old)) { + return(methods::callNextMethod(object, ..., verbose = verbose)) + } + CtwasResult( + gwasStudy = old$gwasStudy, + studyName = old$study, + context = old$context, + method = old$method, + entry = as.list(old$entry), + jointStudies = old$jointStudies, + jointContexts = old$jointContexts + ) + } +) + #' @rdname methodNames #' @export setMethod("methodNames", "CtwasResult", function(x) { @@ -220,40 +394,53 @@ setMethod("contexts", "CtwasResult", function(x) { unique(as.character(x$context)) }) -# Aggregate a per-entry table (finemap or susieAlpha) across all rows, prefixing -# each with the row's (gwasStudy, study, context, method) run identity. +# Stack a per-region ranged payload (the posteriors, or the susie alpha +# tables) across all rows: every row's ranges, its columns kept as mcols and +# prefixed with the row's (gwasStudy, study, context, method) run identity. +# Columns a row lacks are NA-filled. # @noRd -.ctwasAggregateRows <- function(x, getter) { - n <- nrow(x) - if (n == 0L) { - return(NULL) - } +.ctwasAggregateRows <- function(x, payloads) { parts <- compact( - map(seq_len(n), .ctwasAggregateRow, x = x, getter = getter) + map(seq_along(payloads), .ctwasAggregateRow, x = x, payloads = payloads) ) if (length(parts) == 0L) { - return(NULL) + return(GenomicRanges::GRanges()) } - .rbindAligned(parts) + ranges <- exec(c, !!!map(unname(parts), GenomicRanges::granges)) + out <- S4Vectors::`mcols<-`( + ranges, + value = S4Vectors::DataFrame( + .rbindAligned(map(parts, .ctwasRowTable)), + check.names = FALSE + ) + ) + .withGenome(out, .oneBuild(x)) } #' @rdname ctwasPosteriors #' @export setMethod("ctwasPosteriors", "CtwasResult", function(x) { - .ctwasAggregateRows(x, ctwasPosteriors) + .ctwasAggregateRows(x, as.list(x)) }) #' @rdname susieAlpha #' @export setMethod("susieAlpha", "CtwasResult", function(x) { - .ctwasAggregateRows(x, susieAlpha) + .ctwasAggregateRows(x, as.list(x$susieAlpha)) }) #' @rdname show-methods #' @export setMethod("show", "CtwasResult", function(object) { - cat(glue("CtwasResult: {nrow(object)} run(s)\n", .trim = FALSE)) - if (nrow(object) > 0L) { + runs <- distinct(as_tibble( + as.data.frame(mcols(object, use.names = FALSE)[, .CTWAS_ID_COLS]) + )) + cat(glue( + "CtwasResult: {nrow(runs)} run(s) over {length(object)} region ", + "row(s)\n", + .trim = FALSE + )) + if (length(object) > 0L) { cat(glue( " {n_distinct(object$gwasStudy)} GWAS stud(y/ies), ", "{n_distinct(object$method)} method(s): ", @@ -265,45 +452,41 @@ setMethod("show", "CtwasResult", function(object) { # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# A finemap / susieAlpha payload as a flat table. The payloads are ranged now -# (GRanges with the original columns as mcols), so the aggregate view unpacks -# the coordinates back into columns rather than dropping them. +# One row's payload with its run identity attached, ranges and all; NULL when +# the row has none. # @noRd -.ctwasPayloadAsDf <- function(tb) { - if (is.null(tb)) { - return(NULL) - } - if (!methods::is(tb, "GRanges")) { - return(tb) - } - if (length(tb) == 0L) { +.ctwasAggregateRow <- function(i, x, payloads) { + payload <- payloads[[i]] + if (is.null(payload) || length(payload) == 0L) { return(NULL) } - cbind( - data.frame( - chrom = as.character(seqnames(tb)), - start = as.integer(start(tb)), - end = as.integer(GenomicRanges::end(tb)), - stringsAsFactors = FALSE - ), - as.data.frame(mcols(tb)) + md <- mcols(x, use.names = FALSE) + identity <- tibble( + gwasStudy = as.character(md$gwasStudy)[[i]], + study = as.character(md$study)[[i]], + context = as.character(md$context)[[i]], + method = as.character(md$method)[[i]] + ) + # The row identity is authoritative: a payload column of the same name + # (cTWAS's own `context`) gives way to it rather than being duplicated. + own <- .ctwasRowTable(payload) + S4Vectors::`mcols<-`( + payload, + value = S4Vectors::DataFrame( + bind_cols( + slice(identity, rep(1L, length(payload))), + select(own, !any_of(names(identity))) + ), + check.names = FALSE + ) ) } -# One aggregated ctwas row block for entry `i`: `getter`'s per-entry table -# prefixed with the row identity columns; NULL when the entry is empty. +# A ranged row part's columns as a table, for stacking across rows. # @noRd -.ctwasAggregateRow <- function(i, x, getter) { - tb <- .ctwasPayloadAsDf(getter(x$entry[[i]])) - if (is.null(tb) || nrow(tb) == 0L) { - return(NULL) - } - as_tibble(tb) |> - mutate( - gwasStudy = as.character(x$gwasStudy)[[i]], - study = as.character(x$study)[[i]], - context = as.character(x$context)[[i]], - method = as.character(x$method)[[i]], - .before = 1 - ) +.ctwasRowTable <- function(part) { + as_tibble( + as.data.frame(mcols(part), optional = TRUE), + .name_repair = "minimal" + ) } diff --git a/R/CtwasResultEntry.R b/R/CtwasResultEntry.R index f651d7ff..059a8aba 100644 --- a/R/CtwasResultEntry.R +++ b/R/CtwasResultEntry.R @@ -27,6 +27,9 @@ NULL #' \code{group_prior_var} for #' this run, or \code{NULL}. #' @slot regionInfo Per-region metadata, or \code{NULL}. +#' @section Coercion: \code{as(x, "GRanges")} gives the per-gene (and, with +#' SNPs kept, per-SNP) posteriors as ranges -- an error when they could not +#' be placed on the genome and are still a table. #' @seealso \code{\link{CtwasResultEntry}} for the constructor. #' @export setClass( @@ -92,6 +95,31 @@ setMethod("ctwasPosteriors", "CtwasResultEntry", function(x) x@posteriors) #' @export setMethod("susieAlpha", "CtwasResultEntry", function(x) x@susieAlpha) +#' @rdname CtwasResultEntry-class +#' @name coerce,CtwasResultEntry,GRanges-method +#' @aliases coerce,CtwasResultEntry,GRanges-method +#' @usage NULL +#' @exportMethod coerce +setAs("CtwasResultEntry", "GRanges", function(from) { + .ctwasEntryRanges(from@posteriors) +}) + +# Posteriors as ranges: an absent table is no ranges; one the pipeline could +# not place on the genome has no ranges to give. +# @noRd +.ctwasEntryRanges <- function(posteriors) { + if (is.null(posteriors)) { + return(GenomicRanges::GRanges()) + } + if (methods::is(posteriors, "GRanges")) { + return(posteriors) + } + abort(str_c( + "These cTWAS posteriors were not placed on the genome, so they have ", + "no ranges; ctwasPosteriors(x) returns them as a table." + )) +} + #' @rdname ctwasGroupPriors #' @export setMethod( @@ -99,3 +127,44 @@ setMethod( "CtwasResultEntry", function(x) x@groupPriors ) + +#' @rdname show-methods +#' @export +setMethod("show", "CtwasResultEntry", function(object) { + post <- .ctwasPosteriorTable(object@posteriors) + priors <- if (is.null(object@groupPriors)) "not set" else "set" + cat(glue( + "CtwasResultEntry: {.ctwasGeneCount(post)} gene(s) in ", + "{.ctwasRegionCount(post)} region(s); group priors {priors}\n", + .trim = FALSE + )) + invisible(NULL) +}) + +# The posterior table whichever form it is held in: a ranged payload's +# columns, or the table itself. +# @noRd +.ctwasPosteriorTable <- function(posteriors) { + if (methods::is(posteriors, "GRanges")) { + return(as.data.frame(mcols(posteriors))) + } + posteriors %||% data.frame() +} + +# The genes a posterior table scores: its rows that are not SNPs. +# @noRd +.ctwasGeneCount <- function(post) { + if (!is_in("id", colnames(post))) { + return(0L) + } + genes <- if (is_in("type", colnames(post))) post$type != "SNP" else TRUE + length(unique(as.character(post$id[genes]))) +} + +# @noRd +.ctwasRegionCount <- function(post) { + if (!is_in("region_id", colnames(post))) { + return(0L) + } + length(unique(as.character(post$region_id))) +} diff --git a/R/GenotypeDosageSeed.R b/R/GenotypeDosageSeed.R index 1cb58798..24b819aa 100644 --- a/R/GenotypeDosageSeed.R +++ b/R/GenotypeDosageSeed.R @@ -372,8 +372,12 @@ setMethod("extract_array", "GenotypeDosageSeed", function(x, index) { # 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. +# PlinkMatrix is checked for here too, not only when the panel is built: a +# panel loaded from a saved object, such as the bundled examples, was built +# elsewhere. # @noRd .plinkBedSeedRead <- function(x, rows, samples) { + .requireReaderPackage("PlinkMatrix", "PLINK1") variant <- start(.gdSeedRecords(x))[.gdSeedRowRecord(x)[rows]] PlinkMatrix::read_bed_subset( .resolveGenotypeResourcePath(.gdSeedBackend(x)), diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 133fe441..d52e1eef 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -20,15 +20,16 @@ NULL #' the chrom-meta file path (a display/provenance value); the per-chromosome #' payload files live in \code{chromPaths}. #' @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 -#' space. +#' @slot snpInfo data.frame, SNP metadata read from the index/sidecar, its +#' \code{CHR} in UCSC style whatever the file writes. 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 space. #' @slot nSamples Integer, number of samples. #' @slot sampleIds Character vector of sample identifiers. #' @slot pgenPtr Opaque pointer for PLINK2 reader state (NULL otherwise). -#' @slot chromPaths Named character vector mapping canonical chromosome (e.g. -#' \code{"21"}, \code{"X"}) to the per-chromosome payload path/prefix. Empty +#' @slot chromPaths Named character vector mapping each chromosome, in UCSC +#' style (e.g. \code{"chr21"}, \code{"chrX"}), to the per-chromosome +#' payload path/prefix. Empty #' (\code{character(0)}) for a single-file handle; non-empty marks a #' one-file-per-chromosome (sharded) handle whose extraction is routed by #' chromosome. @@ -133,16 +134,15 @@ setMethod("show", "GenotypeHandle", function(object) { #' \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 +#' comma-separated as \code{ld_file,bim_file}). Requires \code{block}. The +#' constructor resolves the row covering \code{block}, then delegates to the #' 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 block The \code{GRanges} window to look up in \code{ldMeta}; the +#' whole file of the row covering it is opened. #' @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 @@ -150,8 +150,8 @@ setMethod("show", "GenotypeHandle", function(object) { #' @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 -#' is genome-wide but only a few chromosomes are needed. Chromosome labels are -#' compared canonically (\code{"chr1"}/\code{"1"} match, \code{23}/\code{X} +#' is genome-wide but only a few chromosomes are needed. Chromosome labels may +#' be in any style (\code{"chr1"}/\code{"1"} match, \code{23}/\code{X} #' etc.). If none of the requested chromosomes are present in the panel, every #' 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 @@ -169,7 +169,7 @@ GenotypeHandle <- function( pvar = NULL, psam = NULL, ldMeta = NULL, - region = NULL, + block = NULL, genoMeta = NULL, chroms = NULL, format = NULL @@ -182,7 +182,7 @@ GenotypeHandle <- function( pvar = pvar, psam = psam, ldMeta = ldMeta, - region = region + block = block ) sources <- .ghResolveSources( path = path, @@ -198,26 +198,25 @@ GenotypeHandle <- function( path = .readGenotypeHandle(path, format = format), plink2Prefix = .makePlink2Handle(plink2Prefix), plink2Triplet = .genotypeHandleFromPlink2Triplet(pgen, pvar, psam), - ldMeta = .genotypeHandleFromLdMeta(ldMeta, region), + ldMeta = .genotypeHandleFromLdMeta(ldMeta, block), genoMeta = .genotypeHandleFromChromMeta(genoMeta, chroms, format) ) } # Validate the bed/bim/fam + pgen/pvar/psam triplet completeness and the -# ldMeta<->region coupling. Returns list(bedComplete, pgenComplete). +# ldMeta<->block coupling. Returns list(bedComplete, pgenComplete). # @noRd -.ghValidateArgs <- function(bed, bim, fam, pgen, pvar, psam, ldMeta, region) { +.ghValidateArgs <- function(bed, bim, fam, pgen, pvar, psam, ldMeta, block) { bedComplete <- .ghTrioComplete(bed, bim, fam, "bed/bim/fam") pgenComplete <- .ghTrioComplete(pgen, pvar, psam, "pgen/pvar/psam") - if (!is.null(ldMeta) && is.null(region)) { - msg <- glue( - "`ldMeta` requires a `region` (a 'chr:start-end' string or a ", - "one-row data.frame with chrom/start/end)." - ) - abort(msg) + if (!is.null(ldMeta) && is.null(block)) { + abort("`ldMeta` requires `block`, the GRanges window to look up.") } - if (is.null(ldMeta) && !is.null(region)) { - abort("`region` is only meaningful when `ldMeta` is supplied.") + if (is.null(ldMeta) && !is.null(block)) { + abort("`block` is only meaningful when `ldMeta` is supplied.") + } + if (!is.null(block)) { + .assertRegionGRanges(block, "`block`") } list(bedComplete = bedComplete, pgenComplete = pgenComplete) } @@ -288,7 +287,7 @@ GenotypeHandle <- function( .ghResolveLdPath <- function(ldMeta, region) { ldPaths <- regionalLdMeta(ldMeta, region)$intersections$LD_file_paths if (length(ldPaths) == 0L) { - regionStr <- deparse(region) + regionStr <- str_flatten(as.character(region), ", ") msg <- glue( "ldMeta: no LD-meta row covers region {regionStr} ", "in {ldMeta}." @@ -296,7 +295,7 @@ GenotypeHandle <- function( abort(msg) } if (length(ldPaths) > 1L) { - regionStr <- deparse(region) + regionStr <- str_flatten(as.character(region), ", ") msg <- glue( "ldMeta: region {regionStr} spans multiple LD-meta rows; ", "only a region within one row is resolved. Restrict the region ", @@ -306,7 +305,7 @@ GenotypeHandle <- function( } ldPath <- ldPaths[[1L]] if (str_detect(ldPath, regex("\\.cor(\\.xz)?$", ignore_case = TRUE))) { - regionStr <- deparse(region) + regionStr <- str_flatten(as.character(region), ", ") msg <- glue( "ldMeta: the LD-meta row for region {regionStr} points at a ", "pre-computed correlation matrix ({ldPath}). pecotmr does not ", @@ -397,9 +396,9 @@ GenotypeHandle <- function( # One-file-per-chromosome (sharded) handle support # --------------------------------------------------------------------------- -# Chromosome labels are canonicalized via canonChrom() (variantId.R) -- the -# single chromosome normalizer used for @chromPaths routing keys and for -# @snpInfo$CHR lookups, so both sides stay consistent (and X/Y/MT survive). +# Chromosome labels are spelled in UCSC style (withChrPrefix(), variantId.R) +# as a meta or a shard is read, so the @chromPaths routing keys and the +# @snpInfo$CHR lookups compare exactly (and X/Y/M survive). # Per-chromosome shard map, tolerant of GenotypeHandle objects deserialized # from before the `chromPaths` slot existed (e.g. an RDS saved by an older @@ -456,7 +455,7 @@ GenotypeHandle <- function( !is.null(names(genoMeta)) ) { return(.metaCheckUniqueChrom(tibble( - chrom = names(genoMeta), + chrom = withChrPrefix(names(genoMeta)), path = unname(genoMeta) ))) } @@ -506,7 +505,7 @@ GenotypeHandle <- function( ) base <- dirname(normalizePath(genoMeta)) .metaCheckUniqueChrom(tibble( - chrom = as.character(meta[[chromCol]]), + chrom = withChrPrefix(meta[[chromCol]]), path = .metaResolvePaths(as.character(meta[[pathCol]]), base) )) } @@ -608,10 +607,7 @@ GenotypeHandle <- function( if (is.null(chroms)) { return(parsed) } - keep <- is_in( - canonChrom(as.character(parsed$chrom)), - canonChrom(as.character(chroms)) - ) + keep <- is_in(parsed$chrom, withChrPrefix(chroms)) if (any(keep)) filter(parsed, keep) else parsed } @@ -650,7 +646,7 @@ GenotypeHandle <- function( # One shard's chromosome -> path mapping. # @noRd .chromShardPaths <- function(shard) { - chroms <- unique(canonChrom(snpInfo(shard)$CHR)) + chroms <- unique(snpInfo(shard)$CHR) set_names(rep(path(shard), length(chroms)), chroms) } diff --git a/R/GenotypeMixture.R b/R/GenotypeMixture.R index 196e84ef..584276da 100644 --- a/R/GenotypeMixture.R +++ b/R/GenotypeMixture.R @@ -130,7 +130,7 @@ setValidity("GenotypeMixture", function(object) { #' @export GenotypeMixture <- function(panels, mixtureWeights) { .gmAssertPanels(panels) - panels <- map(panels, .asLdRef) + panels <- map(map(panels, .asLdRef), .ucscExperiment) if (!all(map_lgl(panels, .gmIsPanel))) { abort("Every element of `panels` must be a genotype panel.") } @@ -154,9 +154,7 @@ GenotypeMixture <- function(panels, mixtureWeights) { sampleMap = .gmSampleMap(experiments), metadata = list(mixtureWeights = w) ) - obj <- methods::new("GenotypeMixture", mae) - validObject(obj) - obj + methods::new("GenotypeMixture", mae) } # @noRd @@ -335,14 +333,18 @@ setMethod("mixtureWeights", "GenotypeMixture", function(x) { S4Vectors::metadata(x)$mixtureWeights }) +# The canonical chrom:pos:A2:A1 id every class renders; the panels' own labels +# stay in the SNP column of the mixture's ranges. #' @rdname variantIds #' @export setMethod("variantIds", "GenotypeMixture", function(x, ...) { - .ldRefVariantIds(x) + .grVariantIds(.gmRanges(x)) }) #' @rdname GenotypeMixture-class #' @param object A \code{GenotypeMixture}. +#' @return \code{show} is called for its side effect and returns +#' \code{invisible(NULL)}. #' @export setMethod("show", "GenotypeMixture", function(object) { w <- mixtureWeights(object) diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index db497836..4b985caf 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -8,7 +8,8 @@ # range -- the genome-wide-across-blocks shape that # qtlEnrichmentPipeline / colocPipeline expect when sweeping a study # across LD blocks. Class-level slots: -# * ldReference GenotypeHandle for the LD reference; required for the +# * ldReference the LD references the fits used, each stored once; the +# ldReference mcols column names each row's. 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). @@ -83,8 +84,8 @@ setClass( .gfmrCheckTupleUniqueness <- function(object) { # Keyed on the element's RANGE rather than on a region_id label. The range # is intrinsic -- it cannot drift out of step with the variants the way a - # stored label can, and it stays correct after subsetRegion() narrows an - # element. Extract key columns directly rather than via `object[, keyCols]`: + # stored label can, and it stays correct after an element is narrowed. + # Extract key columns directly rather than via `object[, keyCols]`: # column-subsetting preserves the class, and older S4Vectors revalidates # that intermediate, spuriously failing. if (length(object) == 0L) { @@ -95,7 +96,7 @@ setClass( map(keyCols, .gfmrColOf, object = object), keyCols )) |> - mutate(range = .rtlRangeKeys(object)) + mutate(range = .keyEmptyElements(object, .rtlRangeKeys(object))) if (nrow(distinct(keyTbl)) < nrow(keyTbl)) { return("(study, method, range) tuple uniqueness violated") } @@ -117,23 +118,25 @@ setClass( #' #' Rows are identified by (\code{study}, \code{method}) plus the element's #' own range, which is derived from the variants rather than stored, so it -#' cannot drift out of step with them and stays correct after -#' \code{\link{subsetRegion}}. +#' cannot drift out of step with them and stays correct when an element's +#' variants are narrowed. #' @param studyName Character vector of study identifiers (per tuple). #' @param method Character vector of fine-mapping method names (per tuple). #' @param entry List / \code{SimpleList} of \code{FineMappingRow} objects. -#' @param blockId Optional character vector (per tuple) keying the external LD -#' block manifest, e.g. \code{"chr22_10516173_17414263"}. Provenance only, -#' not part of the identity key. Supply it when the block BOUNDARIES matter: -#' those are the one thing not recoverable from the variants, since adjacent -#' blocks' spans leave gaps. +#' @param blockId Optional character vector (per tuple) naming each row's +#' block, e.g. \code{"chr22_10516173_17414263"}. Provenance only, not part +#' of the identity key, and a name only: a block's boundaries, which the +#' variants cannot give since adjacent blocks' spans leave gaps, go in +#' \code{region}. Where it is \code{NULL}, or \code{NA} for a row, the +#' row's \code{blockId} is its own span, as \code{"chrom_start_end"}, so +#' every row is named by its block. #' @param dataType Optional assay / modality label ("bulk_rnaseq", #' "methylation"), recorded as a per-row provenance column. Length 1 or #' one per row; \code{NULL} (default) omits the column. #' @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{ldReference} cannot say which row came from which. +#' \code{"individual"} or \code{"sumstat"}. Where it is absent, the result +#' writers read a row's kind from its LD reference: a row with none saw +#' individual-level data. #' @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,21 +144,34 @@ 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 ldReference An optional genotype panel (see -#' \code{\link{readGenotypes}}). +#' @param ldReference The LD reference the fits were computed against -- a +#' genotype panel (see \code{\link{readGenotypes}}), a +#' \code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +#' a list with one per row; \code{NULL} for none. Each distinct reference is +#' stored once. #' @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. #' @param region Optional per-row analysis WINDOW (a \code{GRanges} or #' \code{NULL}) -- the interval each row's fit was run over, carried -#' 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. -#' @return A \code{GwasFineMappingResult} object. +#' forward as provenance; not part of the identity key. It is recorded as +#' given, so each range must contain its row's variants. +#' \code{\link{fineMappingPipeline}} always sets it, from the window of the +#' input row. \code{NULL} (default) omits the column, and +#' \code{\link{genomicRegion}} then derives the window from the span of the +#' variants present. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. +#' @return A \code{GwasFineMappingResult} object. Its logical +#' \code{regionGiven} column says, per row, whether the window was given +#' or is the span of the variants; \code{\link{fineMappingPipeline}} +#' carries it over from the input. See \code{\linkS4class{GwasSumStats}} +#' for how the pipelines use it. #' @examples #' tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), #' pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) -#' fe <- fineMappingRow( +#' fe <- FineMappingRow( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) #' GwasFineMappingResult(studyName = "t1", method = "susie", entry = list(fe)) #' @export @@ -169,41 +185,112 @@ GwasFineMappingResult <- function( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) { n <- length(studyName) if (length(method) != n || length(entry) != n) { - abort("`study`, `method`, and `entry` must all have the same length.") + abort( + "`studyName`, `method`, and `entry` must all have the same length." + ) } entry <- map(entry, .asFmRowPayload) .checkRowPayloads(entry, "FineMappingRow", "fine-mapping") + .gfmrRefuseSplitFits(entry) cols <- list( study = as.character(studyName), method = as.character(method), susieFit = S4Vectors::SimpleList(map(entry, susieFit)), - cvResult = S4Vectors::SimpleList(map(entry, cvResult)) + cvResult = S4Vectors::SimpleList(map(entry, cvResult)), + fitVariants = IRanges::CharacterList(map(entry, .fmRowFitVariants)) ) |> - .appendBlockIdCol(blockId, n) |> + .appendBlockIdCol(blockId %||% rep(NA_character_, n), n) |> .appendTraitPosCol(traitPos, n) |> .appendRegionCol(region, n) |> .appendFmProvenanceCols(dataType, dataSource, weightStandardized, n) - dfArgs <- c(cols, list(check.names = FALSE)) - # Each entry's variants become one ELEMENT, its topLoci that element's - # inner mcols, and its fit/cv payload outer mcols. A multi-seqname entry - # splits by chromosome with its metadata row replicated. + .withMetadata(.gfmrBuild(entry, cols, region, ldReference), metadata) +} + +# The validated collection from its entries and metadata columns. Each +# entry's variants become one ELEMENT, its topLoci that element's inner +# mcols, and its fit/cv payload outer mcols. A multi-seqname entry -- only a +# fit-less one gets this far -- splits by chromosome with its metadata row +# replicated. +# @noRd +.gfmrBuild <- function(entry, cols, region, ldReference) { + n <- length(entry) + dict <- .ldRefDict(.ldRefPerTuple(ldReference, n)) + dfArgs <- c(cols, list(ldReference = dict$keys, check.names = FALSE)) split <- .rtlSplitBySeqname(map(entry, variants)) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) + pieces <- .rtlBindElements(split$entry) grl <- S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(split$entry), - value = md[split$fromIdx, , drop = FALSE] - ) - obj <- new( - "GwasFineMappingResult", - grl, - ldReference = .asLdRef(ldReference) + pieces, + value = .gfmrPieceMetadata( + exec(S4Vectors::DataFrame, !!!dfArgs), + split, + .gfmrGivenRegions(region, n), + pieces + ) ) - validObject(obj) - obj + new("GwasFineMappingResult", .rtlNamed(grl), ldReference = dict$refs) +} + +# The window each entry was given: its `region`, when the caller passed one. +# A `blockId` is a name, and gives no window. +# @noRd +.gfmrGivenRegions <- function(region, n) { + if (is.null(region)) { + return(list(ranges = .placeholderRanges(n), given = rep(FALSE, n))) + } + list(ranges = .bareRanges(region), given = rep(TRUE, n)) +} + +# Each piece's metadata row: its entry's, replicated across the pieces a +# multi-chromosome entry splits into, and a blockId for every piece -- the +# caller's, else the piece's own span as "chrom_start_end" -- so each row is +# named by its block whether or not the caller named it. An empty piece spans +# nothing and keeps NA. `regionGiven` records which pieces were given their +# range. A row given none stores no `region`, where genomicRegion() reads its +# span, unless another row was given one and the column has to exist. +# @noRd +.gfmrPieceMetadata <- function(md, split, given, pieces) { + out <- md[split$fromIdx, , drop = FALSE] + out$blockId <- coalesce(as.character(out$blockId), .rtlRangeKeys(pieces)) + ranges <- given$ranges[split$fromIdx] + has <- given$given[split$fromIdx] + .refuseUncontainedRegions(ranges, has, pieces, "GwasFineMappingResult") + cols <- .regionColumns(ranges, has, .rowSpanRanges(pieces)) + if (any(cols$regionGiven)) { + out$region <- cols$region + } + out$regionGiven <- cols$regionGiven + out +} + +# A multi-chromosome entry is split into one row per chromosome, its metadata +# copied onto each. Variants and their top-loci split cleanly, but a fit does +# not: its effects span every variant it was given, so each piece would carry +# the whole fit, and coloc and the enrichment would read it once per piece. An +# entry carrying a fit must therefore lie on one chromosome -- one LD block, +# as fineMappingPipeline's entries do. +# @noRd +.gfmrRefuseSplitFits <- function(entry) { + multi <- .multiChromosomeEntries(entry) + bad <- multi[map_lgl(entry[multi], .fmRowCarriesFit)] + if (length(bad) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "GwasFineMappingResult: `entry` element(s) ", + "{str_flatten(utils::head(bad, 5L), ', ')} span more than one ", + "chromosome but carry a single fit, which cannot be split across ", + "rows. Fine-map each LD block separately and pass one entry per block." + )) +} + +# @noRd +.fmRowCarriesFit <- function(e) { + length(susieFit(e)) > 0L || !is.null(cvResult(e)) } # Internal: return integer row indices of `x` where every (column, value) @@ -222,19 +309,27 @@ setMethod("contexts", "GwasFineMappingResult", function(x) NULL) #' @export setMethod("traitNames", "GwasFineMappingResult", function(x) NULL) -# Per-tuple lookup keyed by (study, method, blockId). The generic -# accepts the full set of selectors; `context` / `trait` are QTL-only and a +# One fit, keyed by (study, method): a study fine-mapped block by block is one +# row per LD block, so the fit is all of them; `blockId` picks one block by +# name. The generic accepts +# the full set of selectors; `context` / `trait` are QTL-only and a # GwasFineMappingResult refuses them rather than ignoring them, the same way -# sumStats(GwasSumStats) does. `region` is the per-block disambiguator -# for multi-block genome-wide collections. +# sumStats(GwasSumStats) does. #' @rdname fineMappingResult #' @export setMethod( "fineMappingResult", "GwasFineMappingResult", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + blockId = NULL + ) { .gwasFmrRefuseQtlSelectors(context, trait) - x[.tupleSelectRowGwasFmr(x, studyName, method)] + x[.tupleSelectRowsGwasFmr(x, studyName, method, blockId)] } ) @@ -249,24 +344,11 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL, - returnList = FALSE + blockId = NULL ) { .gwasFmrRefuseQtlSelectors(context, trait) - idx <- .tupleSelectRowGwasFmr(x, studyName, method, region) - pip <- .fmrRowPip(.fmrRowParts(x, idx)) - if (!isTRUE(returnList)) { - return(pip) - } - # Documented as "a per-entry list keyed by identity tuple"; the QTL - # method has always honoured it and this one silently returned the - # flat vector. A GWAS row is keyed by (study, method). - set_names( - list(pip), - glue( - "{as.character(x$study)[idx]}|{as.character(x$method)[idx]}" - ) - ) + idx <- .tupleSelectRowGwasFmr(x, studyName, method, blockId) + .fmrRowPip(.fmrRowParts(x, idx)) } ) @@ -290,7 +372,7 @@ setMethod( "GwasFineMappingResult has no context or trait axis, so ", "{str_flatten(sprintf('`%s`', bad), ' and ')} ", "{if (length(bad) == 1L) 'does' else 'do'} not select anything. ", - "Select with `study`, `method` and `region`." + "Select with `studyName`, `method` and `blockId`." )) } @@ -301,7 +383,7 @@ setMethod( # Row selector for the base delegating accessors (credibleSets / topLoci / # marginalEffects / susieFit / variantIds live on -# FineMappingResultBase, AllClasses.R). The Gwas selector threads `region`. +# FineMappingResultBase, AllClasses.R). The Gwas selector threads `blockId`. setMethod( ".fmrSelectEntry", "GwasFineMappingResult", @@ -311,14 +393,17 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { # No refusal here, unlike the public accessors: this is the blind # delegation point for the shared base accessors, and callers such # as the VCF writer thread a whole selector record through it # without knowing the class. The user-facing entry points are where # a QTL-only selector is a mistake worth reporting. - .fmrRowParts(x, .tupleSelectRowGwasFmr(x, studyName, method, region)) + .fmrRowParts( + x, + .tupleSelectRowGwasFmr(x, studyName, method, blockId) + ) } ) @@ -334,10 +419,6 @@ setMethod("show", "GwasFineMappingResult", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldReference)) { - "NULL" - } else { - .ldRefLabel(object@ldReference) - } + ldSrc <- .ldRefsLabel(ldReference(object), "NULL") cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) diff --git a/R/H2Estimate.R b/R/H2Estimate.R index 1f162578..770ec8f0 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -126,6 +126,36 @@ setMethod("scoreStats", "H2Estimate", function(object) { object@scoreStats }) +# Each slot an H2Estimate was saved under before its slots were renamed, and +# its name now. +# @noRd +.H2_RENAMED_SLOTS <- c( + h2 = "estimate", + h2Se = "estimateSe", + local = "localBlocks", + tauBlocks = "annotationJackknifeCoefs" +) + +# An H2Estimate saved before the rename holds its estimates under the old +# names, which the inherited update would drop as slots the class no longer +# has, leaving the estimate empty; they are moved to the new names first. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "H2Estimate", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'H2Estimate')") + } + methods::callNextMethod( + .renameSavedSlots(object, .H2_RENAMED_SLOTS), + ..., + verbose = verbose + ) + } +) + # ============================================================================= # Show diff --git a/R/JointGroup.R b/R/JointGroup.R index 3be7be74..44b5e120 100644 --- a/R/JointGroup.R +++ b/R/JointGroup.R @@ -204,6 +204,13 @@ setClass("TwasJointPipeline", contains = "JointPipeline") # @noRd .jgN <- function(g) g@N +# The LD reference a group was fitted against: a summary-statistics group's +# own, NULL for an individual-level one, whose LD comes from its genotypes. +# @noRd +.jgLdRefOf <- function(g) { + if (methods::is(g, "SumStatsJointGroup")) .jgLdRef(g) else NULL +} + # 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 diff --git a/R/LdBlocks.R b/R/LdBlocks.R index 25c2401b..a18f98e6 100644 --- a/R/LdBlocks.R +++ b/R/LdBlocks.R @@ -11,50 +11,10 @@ #' @include AllGenerics.R NULL -# Coerce an LD-block specification to the GRanges the splitters consume. -# -# Accepts a `GRanges`, a data.frame with chrom/start/end (plus an optional -# `blockId`), or a path to a delimited file holding those columns. +# Coerce an LD-block specification to the GRanges the splitters consume: a +# GRanges, or the path of a BED file, read as BED. The rules are those of +# every window argument (.asRegionRanges()). # @noRd .asLdBlockRanges <- function(x) { - if (methods::is(x, "GRanges")) { - return(x) - } - if (is.character(x) && length(x) == 1L) { - x <- .readManifest(x) - } - if (!is.data.frame(x)) { - msg <- glue( - "`ldBlocks` must be a GRanges, a data.frame with ", - "chrom/start/end, or a path to one (got {class(x)[[1L]]})." - ) - abort(msg) - } - .ldBlockTableToRanges(x) -} - -# One block per row. `blockId` is carried into mcols when present so the key -# survives; without it the splitter falls back to the block's coordinates. -# @noRd -#' @importFrom checkmate assertNames -.ldBlockTableToRanges <- function(df) { - assertNames( - colnames(df), - must.include = c("chrom", "start", "end"), - what = "colnames", - .var.name = "ldBlocks table" - ) - exec( - GenomicRanges::GRanges, - seqnames = as.character(df$chrom), - ranges = IRanges::IRanges( - start = as.integer(df$start), - end = as.integer(df$end) - ), - !!!compact(list( - blockId = if (is_in("blockId", colnames(df))) { - as.character(df$blockId) - } - )) - ) + .asRegionRanges(x, "`ldBlocks`") } diff --git a/R/LdEigen.R b/R/LdEigen.R index b1daeb3d..29ae76d0 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -82,7 +82,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 eigenList A list with one entry per LD block. -#' @param ldBlocks A \code{GRanges} of LD block intervals. +#' @param ldBlocks The LD block intervals: a \code{GRanges}, or the path +#' of a BED file, read as BED with a 0-based start. #' @param nSamples Integer, sample size of the LD reference panel. #' @param inSample Logical, whether the reference is the GWAS cohort. #' @param genome Character, genome build; recorded in \code{seqinfo()}. @@ -115,7 +116,7 @@ LdEigen <- function( assertDataFrame(snpInfo) assertList(eigenList) assertCount(nSamples, positive = TRUE) - obj <- methods::new( + methods::new( "LdEigen", .ldStatRanges(snpInfo, genome), ldBlocks = .asLdBlockRanges(ldBlocks), @@ -124,8 +125,6 @@ LdEigen <- function( eigenList = eigenList, eigenvalueTruncation = as.numeric(eigenvalueTruncation) ) - validObject(obj) - obj } #' @importFrom checkmate assertCount assertFlag @@ -148,8 +147,8 @@ LdEigen <- function( #' standard error from a delete-one-block jackknife, so it requires at #' 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 +#' \code{GRanges}, or the path of a BED file, read as BED with a 0-based +#' start. 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 @@ -172,8 +171,8 @@ LdEigen <- function( #' 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)) +#' blocks <- GenomicRanges::GRanges("chr22", +#' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000))) #' ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") #' ldEigen #' length(eigenList(ldEigen)) @@ -217,7 +216,7 @@ buildLdEigen <- function( .ldEigenFromPanel <- function(prep, inSample, truncation) { gr <- .ldStatRanges(prep$snpInfo, prep$genome) S4Vectors::mcols(gr)$panelRow <- prep$panelRow - obj <- methods::new( + methods::new( "LdEigen", gr, ldBlocks = .asLdBlockRanges(prep$ldBlocks), @@ -227,8 +226,6 @@ buildLdEigen <- function( eigenvalueTruncation = as.numeric(truncation), ldReference = prep$ldReference ) - validObject(obj) - obj } # One block's decomposition, truncated to the leading components carrying diff --git a/R/LdMatrix.R b/R/LdMatrix.R index 59023495..25e4db19 100644 --- a/R/LdMatrix.R +++ b/R/LdMatrix.R @@ -253,15 +253,13 @@ LdMatrix <- function( # @noRd .ldmNew <- function(gr, R, nSamples, mixtureWeights) { - obj <- methods::new( + 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 @@ -384,7 +382,7 @@ LdMatrix <- function( out <- tibble( SNP = snp %||% formatVariantId( - canonChrom(as.character(tbl$chrom)), + as.character(tbl$chrom), as.integer(tbl$pos), as.character(tbl$A2), as.character(tbl$A1) @@ -462,15 +460,13 @@ LdMatrix <- function( ) ids <- rownames(ref@correlation)[common] gr <- .ldmMixtureVariants(ref[common], components, aligned, w) - obj <- methods::new( + methods::new( "LdMatrix", gr, correlation = `dimnames<-`(R, list(ids, ids)), nSamples = .ldmMixtureN(map_int(components, nSamples), w), mixtureWeights = w ) - validObject(obj) - obj } # @noRd @@ -605,6 +601,18 @@ setMethod("extractROWS", "LdMatrix", function(x, i) { #' @export setMethod("ldMatrix", "LdMatrix", function(x) x@correlation) +#' @rdname ldMatrix +#' @importFrom S4Arrays as.matrix +#' @export +setMethod("as.matrix", "LdMatrix", function(x, ...) ldMatrix(x)) + +#' @rdname ldMatrix +#' @name coerce,LdMatrix,matrix-method +#' @aliases coerce,LdMatrix,matrix-method +#' @usage NULL +#' @exportMethod coerce +setAs("LdMatrix", "matrix", function(from) ldMatrix(from)) + #' @rdname nSamples #' @export setMethod("nSamples", "LdMatrix", function(x, ...) x@nSamples) @@ -615,10 +623,12 @@ setMethod("mixtureWeights", "LdMatrix", function(x) { if (length(x@mixtureWeights) == 0L) NULL else x@mixtureWeights }) +# The canonical chrom:pos:A2:A1 id every class renders; the labels the matrix +# was given stay in mcols(x)$SNP. #' @rdname variantIds #' @export setMethod("variantIds", "LdMatrix", function(x, ...) { - as.character(S4Vectors::mcols(x)$SNP) + .grVariantIds(methods::as(x, "GRanges")) }) #' @rdname af @@ -631,6 +641,8 @@ setMethod("af", "LdMatrix", function(x, ...) { #' @rdname LdMatrix-class #' @param object An \code{LdMatrix}. +#' @return \code{show} is called for its side effect and returns +#' \code{invisible(NULL)}. #' @export setMethod("show", "LdMatrix", function(object) { n <- if (is.na(object@nSamples)) "unknown" else object@nSamples diff --git a/R/LdScore.R b/R/LdScore.R index 6442a306..c0e2a171 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -64,7 +64,8 @@ setClass( #' 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. +#' @param ldBlocks The LD block intervals: a \code{GRanges}, or the path +#' of a BED file, read as BED with a 0-based start. #' @param nSamples Integer, sample size of the LD reference panel. #' @param inSample Logical, whether the reference is the GWAS cohort. #' @param genome Character, genome build; recorded in \code{seqinfo()}. @@ -107,7 +108,7 @@ LdScore <- function( ) ) ) - obj <- methods::new( + methods::new( "LdScore", scored, ldBlocks = .asLdBlockRanges(ldBlocks), @@ -115,8 +116,6 @@ LdScore <- function( inSample = isTRUE(inSample), ldMatrixList = ldMatrixList ) - validObject(obj) - obj } #' @importFrom checkmate assertCount assertFlag @@ -148,8 +147,8 @@ LdScore <- function( #' standard error from a delete-one-block jackknife, so it requires at #' 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 +#' \code{GRanges}, or the path of a BED file, read as BED with a 0-based +#' start. 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 @@ -176,8 +175,8 @@ LdScore <- function( #' 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)) +#' blocks <- GenomicRanges::GRanges("chr22", +#' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000))) #' ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") #' ldScore #' head(S4Vectors::mcols(ldScore)$ldScores) @@ -380,6 +379,9 @@ setMethod("ldMatrixList", "LdScore", function(x) { # 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) + ldFactor <- .ldRefFactor(ldReference, block$rows) + list( + R = crossprod(ldFactor) / (nrow(ldFactor) - 1), + snpIdx = block$idx + ) } diff --git a/R/LdStatistic.R b/R/LdStatistic.R index bcd87248..40fd4c17 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -228,12 +228,7 @@ setClass( 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)) - ) + spans <- .asLdBlockRanges(ldBlocks) gr <- .ldRefRanges(panel) hits <- GenomicRanges::findOverlaps(gr, spans) if (anyDuplicated(S4Vectors::queryHits(hits)) > 0L) { @@ -348,7 +343,7 @@ setClass( # silently get a range covering everything between them. # @noRd .h2RefBlockChrom <- function(block) { - chrom <- unique(withChrPrefix(as.character(seqnames(block$gr)))) + chrom <- unique(as.character(seqnames(block$gr))) if (length(chrom) != 1L) { abort(glue( "an LD block spans {length(chrom)} chromosomes ", @@ -448,6 +443,32 @@ setMethod("ldBlocks", "LdStatistic", function(x) x@ldBlocks) #' @export setMethod("ldReference", "LdStatistic", function(x) x@ldReference) +# An LdStatistic saved before the reference's sample size was named +# `nSamples` holds it as `nRef`, and one saved before statistics kept their LD +# reference has no `ldReference` slot: it stored what it needs of its blocks' +# LD, which a NULL reference now says. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "LdStatistic", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message(str_c("updateObject(object = '", class(object)[[1L]], "')")) + } + object <- .renameSavedSlots(object, c(nRef = "nSamples")) + if (!methods::.hasSlot(object, "ldReference")) { + object <- `slot<-`( + object, + "ldReference", + check = FALSE, + value = NULL + ) + } + methods::callNextMethod(object, ..., verbose = verbose) + } +) + # ============================================================================= # Reading an LD statistic's blocks # ----------------------------------------------------------------------------- diff --git a/R/MashPrior.R b/R/MashPrior.R index 878f45e5..d5798176 100644 --- a/R/MashPrior.R +++ b/R/MashPrior.R @@ -130,9 +130,7 @@ setClass( #' @export MashPrior <- function(fullFit = NULL, cvFits = NULL) { assertList(cvFits, null.ok = TRUE) - obj <- new("MashPrior", fullFit = fullFit, cvFits = cvFits) - validObject(obj) - obj + new("MashPrior", fullFit = fullFit, cvFits = cvFits) } #' @rdname fullFit diff --git a/R/MethodOptions.R b/R/MethodOptions.R index 95522d97..786feca7 100644 --- a/R/MethodOptions.R +++ b/R/MethodOptions.R @@ -322,7 +322,6 @@ setClass("MethodOptions", contains = "SimpleList") # is no foreign signature to check against. # @noRd #' @importFrom rlang is_named -#' @importFrom purrr map2_lgl #' @importFrom S4Vectors SimpleList metadata metadata<- .newMethodOptions <- function( callee, @@ -524,24 +523,17 @@ setClass("MethodOptions", contains = "SimpleList") # --- nested per-engine bundles --------------------------------------------- -# Every entry must have been built by a constructor its key accepts. -# Checked before building so the message is the user's, not purrr's "In -# index: 1. With name: foo." framing around it. The acceptable engines come -# from the key's own constructor rather than from the key: several keys may -# share one engine (lasso and enet are both glmnet). `engines` overrides -# that for a key whose paths run more than one -- TWAS's lasso fits with -# glmnet on individual data and with pecotmr's lassosum solver on summary -# statistics, and either constructor is a legitimate way to configure it. +# Every entry must have been built by its key's own constructor, or be a +# plain list, which declares no engine. Checked before building so the +# message is the user's, not purrr's "In index: 1. With name: foo." framing +# around it. The engine to match comes from the key's constructor rather +# than from the key: several keys may share one engine (lasso and enet are +# both glmnet). # @noRd -.nestedAssertEngines <- function(elements, ctors, engines, label) { +.nestedAssertEngines <- function(elements, ctors, label) { declared <- map_chr(elements, .nestedDeclaredEngine) - allowed <- map( - names(elements), - .nestedAllowedEngines, - ctors = ctors, - engines = engines - ) - mismatch <- which(!map2_lgl(declared, allowed, .nestedEngineMatches)) + expected <- map_chr(names(elements), .nestedExpectedEngine, ctors = ctors) + mismatch <- which(!is.na(declared) & declared != expected) if (length(mismatch) == 0L) { return(invisible(NULL)) } @@ -549,27 +541,10 @@ setClass("MethodOptions", contains = "SimpleList") abort(glue( "{label}: the `{names(elements)[i]}` entry was built with the ", "constructor for '{declared[[i]]}', but `{names(elements)[i]}` ", - "uses the ", - "{str_flatten(sprintf(\"'%s'\", allowed[[i]]), ' or ')} ", - "constructor. ", - "{if (length(allowed[[i]]) > 1L) 'Pass one of those' else ", - "'Pass that'}, or a plain list." + "uses the '{expected[[i]]}' constructor. Pass that, or a plain list." )) } -# A plain-list entry declares no engine, so nothing to match. -# @noRd -.nestedEngineMatches <- function(declared, allowed) { - is.na(declared) || is_in(declared, allowed) -} - -# The engines a key accepts: the caller's list for that key when given, -# otherwise the single one the key's own constructor produces. -# @noRd -.nestedAllowedEngines <- function(key, ctors, engines) { - engines[[key]] %||% .nestedExpectedEngine(key, ctors) -} - # The engine a key's own constructor produces, so an entry built by a # different engine's constructor can be told apart from one built by a # sibling key that shares the same engine. diff --git a/R/MethodParam.R b/R/MethodParam.R index d6dddff6..42d60062 100644 --- a/R/MethodParam.R +++ b/R/MethodParam.R @@ -70,8 +70,8 @@ setClassUnion("MethodOptions_OR_NULL", c("MethodOptions", "NULL")) #' does not attempt to mirror its semantics. #' @section List interface: #' A \code{MethodParam} reads like a list: \code{$} and \code{[[} fetch a -#' field, and \code{names()}, \code{length()} and \code{as.list()} describe -#' it. +#' field, \code{$<-} replaces one, and \code{names()}, \code{length()} and +#' \code{as.list()} describe it. #' #' Those last three report only the fields that are \strong{set}. A slot #' holding \code{NULL} is absent from all three, while \code{$} and @@ -179,6 +179,82 @@ setMethod("as.list", "MethodParam", function(x, ...) { set_names(map(set, slot, object = x), set) }) +#' @rdname MethodParam-class +#' @param value The setting's new value; \code{NULL} unsets a setting that +#' may be unset. +#' @return \code{$<-} returns the record rebuilt with that setting replaced. +#' The rebuild goes through the class's own constructor, so the value is +#' normalised and checked exactly as it is when the record is built, and a +#' value the constructor would refuse is refused here too. A setting that +#' cannot change once the record exists is refused, saying why. +#' @export +setReplaceMethod("$", "MethodParam", function(x, name, value) { + .paramReplace(x, name, value) +}) + +# The one replacement path, shared by `$<-` and the deprecated per-field +# setters. `$<-` takes its name literally, so a setter holding the field name +# in a variable cannot reach it through `$<-` itself. +# @noRd +.paramReplace <- function(x, name, value) { + .paramAssertField(x, name) + .paramAssertSettable(x, name) + .paramRebuild(x, name, value) +} + +# Settings `$<-` refuses, by class, and why. CredibleSetParam's L / Lgreedy +# seed each SuSiE-family fit's own arguments, so changing one needs a refit; +# a record that took the new value would look applied without being so. The +# other two are assembled by their constructors from several arguments, so +# there is no single value to put back. +# @noRd +.PARAM_FIXED_FIELDS <- list( + CredibleSetParam = c( + maxNumSingleEffects = str_c( + "it seeds each SuSiE-family fit's own arguments, so changing it ", + "needs a refit" + ), + maxNumSingleEffectsGreedy = str_c( + "it seeds each SuSiE-family fit's own arguments, so changing it ", + "needs a refit" + ) + ), + MashComponentParam = c( + components = str_c( + "MashComponentParam() assembles it from its canonical / pca / ", + "flash / flashNonneg arguments" + ) + ), + PvalMethodsParam = c( + methods = "PvalMethodsParam() assembles it from one argument per method" + ) +) + +# @noRd +.paramAssertSettable <- function(x, name) { + cls <- class(x)[[1L]] + fixed <- .PARAM_FIXED_FIELDS[[cls]] + if (!is_in(name, names(fixed))) { + return(invisible(NULL)) + } + abort(glue( + "`{name}` cannot be replaced on a {cls}: {fixed[[name]]}. Build a new ", + "{cls}() instead." + )) +} + +# The record rebuilt by its own constructor from every current setting plus +# the replaced one. Every settable class's constructor takes exactly its +# slots, so a replacement runs the constructor's normalisation and checks +# rather than a bare slot write that could store what construction refuses. +# @noRd +.paramRebuild <- function(x, name, value) { + cls <- class(x)[[1L]] + fields <- set_names(map(slotNames(x), slot, object = x), slotNames(x)) + fields[name] <- list(value) + exec(get(cls, mode = "function", envir = topenv()), !!!fields) +} + #' @rdname MethodParam-class #' @param object A \code{MethodParam} object. #' @return \code{show} is called for its side effect and returns @@ -1003,6 +1079,9 @@ setValidity("MethodsSelectionParam", function(object) { if (.isMethodParam(value)) { return(.paramNestedText(value)) } + if (methods::is(value, "BiocParallelParam")) { + return(.paramBpparamText(value)) + } if (is.list(value) && !is.null(names(value))) { return(str_flatten(names(value), ", ")) } @@ -1014,6 +1093,15 @@ setValidity("MethodsSelectionParam", function(object) { str_flatten(format(value), ", ") } +# A BiocParallelParam by its class and worker count; format() would print +# the reference object's every field. +# @noRd +#' @importFrom BiocParallel bpnworkers +.paramBpparamText <- function(value) { + n <- bpnworkers(value) + glue("{class(value)[[1L]]} ({n} worker{if (n == 1L) '' else 's'})") +} + # A nested Param by what it CONTAINS, not by its slot names. The # aggregators hold their per-method entries in one list slot, so reporting # slot names would say "components" where the reader wants "pca". diff --git a/R/MultiStudyQtlDataset.R b/R/MultiStudyQtlDataset.R index e9d27060..32ac4fa6 100644 --- a/R/MultiStudyQtlDataset.R +++ b/R/MultiStudyQtlDataset.R @@ -1,11 +1,12 @@ # ============================================================================= # MultiStudyQtlDataset S4 class # ----------------------------------------------------------------------------- -# Multi-study container that holds a named list of individual-level -# QtlDataset objects plus an optional QtlSumStats collection for -# summary-statistic-only studies. Used as the entry point for -# multi-study pipelines (fineMappingPipeline, twasWeightsPipeline) that -# orchestrate joint or per-study analyses across multiple cohorts. +# Multi-study container: a SimpleList of individual-level QtlDataset objects, +# keyed by study, plus an optional QtlSumStats collection for +# summary-statistic-only studies. Used as the entry point for multi-study +# pipelines (fineMappingPipeline, twasWeightsPipeline) that orchestrate joint +# or per-study analyses across multiple cohorts. Being a List, it subsets, +# indexes and maps like one: ms["s1"], ms[["s1"]], names(ms), lapply(ms, f). # ============================================================================= #' @include QtlDataset.R qtlSumStats.R @@ -21,6 +22,12 @@ setClassUnion("QtlSumStats_OR_NULL", c("QtlSumStats", "NULL")) #' \code{QtlSumStats} collection of summary-statistic-only studies. Used as #' the input to multi-study fine-mapping and colocboost-style analyses. #' +#' It is a \code{\link[S4Vectors]{SimpleList}} of the individual-level +#' studies, keyed by study name, so \code{length()}, \code{names()}, +#' \code{[[} and \code{[} address them as on any Bioconductor list; +#' \code{[} keeps the summary-statistic studies whole and still requires two +#' studies in total. +#' #' At least two studies must be present in total, counting \code{qtlDatasets} #' entries plus the studies in \code{sumStats}. #' @@ -29,17 +36,14 @@ setClassUnion("QtlSumStats_OR_NULL", c("QtlSumStats", "NULL")) #' validity). No cross-checking is performed against \code{sumStats} variant #' positions, since summary statistics are already computed and cannot be #' re-aligned at construction time. -#' @slot qtlDatasets A named list of \code{QtlDataset} objects, keyed by study -#' identifier. #' @slot sumStats An optional \code{QtlSumStats} carrying additional #' summary-statistic-only studies. \code{NULL} when absent. #' @export setClass( "MultiStudyQtlDataset", - representation( - qtlDatasets = "list", - sumStats = "QtlSumStats_OR_NULL" - ), + contains = "SimpleList", + representation(sumStats = "QtlSumStats_OR_NULL"), + prototype(elementType = "QtlDataset"), validity = function(object) .validateMultiStudyQtlDataset(object) ) @@ -48,9 +52,10 @@ setClass( # @noRd .validateMultiStudyQtlDataset <- function(object) { # 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 <- .msqdCheckDatasets(object@qtlDatasets) + # reads the list the first check just validated, and trait consistency + # reads across the studies the count check just confirmed. The element + # type is SimpleList's own check (elementType), which runs first. + slotErrors <- .msqdCheckDatasets(as.list(object)) if (length(slotErrors) > 0L) { return(slotErrors) } @@ -70,15 +75,22 @@ setClass( if (!isTRUE(res)) { return(str_c("'qtlDatasets' ", res)) } - .msqdCheckDatasetTypes(qtlDatasets) + NULL } +# SimpleList refuses an element of another class as well, but without naming +# it, so the constructor checks first. # @noRd -.msqdCheckDatasetTypes <- function(qtlDatasets) { - if (any(!map_lgl(qtlDatasets, .msqdIsQtlDataset))) { - return("every element of 'qtlDatasets' must be a QtlDataset") +.msqdAssertDatasetTypes <- function(qtlDatasets) { + bad <- names(qtlDatasets)[!map_lgl(qtlDatasets, .msqdIsQtlDataset)] + if (length(bad) == 0L) { + return(invisible(NULL)) } - NULL + abort(glue( + "every element of `qtlDatasets` must be a QtlDataset; ", + "{str_flatten(bad, ', ')} {if (length(bad) == 1L) 'is' else 'are'} ", + "not." + )) } # @noRd @@ -89,7 +101,7 @@ setClass( # At least 2 studies in total (individual-level + summary-statistic). # @noRd .msqdCheckStudyCount <- function(object) { - nQtl <- length(object@qtlDatasets) + nQtl <- length(object) nSumstats <- if (is.null(object@sumStats)) { 0L } else { @@ -109,12 +121,12 @@ setClass( # identical rowRanges. # @noRd .msqdCheckTraitConsistency <- function(object) { - if (length(object@qtlDatasets) < 2L) { + if (length(object) < 2L) { return(NULL) } - traitRanges <- map(object@qtlDatasets, .msqdTraitRanges) + traitRanges <- map(as.list(object), .msqdTraitRanges) pairs <- utils::combn(seq_along(traitRanges), 2L) - dsNames <- names(object@qtlDatasets) + dsNames <- names(object) list_c(compact(map( seq_len(ncol(pairs)), .msqdPairErrors, @@ -154,7 +166,7 @@ setClass( # One context's (trait, range) pairs in row order. # @noRd .msqdContextTraitRanges <- function(ctx, qd) { - se <- molecularTraits(qd, ctx) + se <- .qtlContextSe(qd, ctx) map( seq_along(rownames(se)), .msqdTraitRangePair, @@ -184,10 +196,10 @@ setClass( # TRUE when trait `tid`'s ranges match across the two datasets. # @noRd .msqdRangesEqual <- function(tid, a, b) { - isTRUE(all.equal( - canonChrom(GenomicRanges::seqnames(a[[tid]])), - canonChrom(GenomicRanges::seqnames(b[[tid]])) - )) && + identical( + as.character(GenomicRanges::seqnames(a[[tid]])), + as.character(GenomicRanges::seqnames(b[[tid]])) + ) && GenomicRanges::start(a[[tid]]) == GenomicRanges::start(b[[tid]]) && GenomicRanges::end(a[[tid]]) == GenomicRanges::end(b[[tid]]) } @@ -242,18 +254,59 @@ setClass( #' @export MultiStudyQtlDataset <- function(qtlDatasets, sumStats = NULL) { assertList(qtlDatasets, min.len = 1L, names = "unique") - obj <- new( + .msqdAssertDatasetTypes(qtlDatasets) + new( "MultiStudyQtlDataset", - qtlDatasets = qtlDatasets, + listData = qtlDatasets, sumStats = sumStats ) - validObject(obj) - obj } -#' @rdname qtlDatasets +# Selecting studies keeps the summary-statistic ones whole, and re-checks the +# result: the stock List subset does not run validity, and a selection below +# two studies in total is not a multi-study dataset. +setMethod("extractROWS", "MultiStudyQtlDataset", function(x, i) { + ans <- methods::callNextMethod() + validObject(ans) + ans +}) + +# Before it became a SimpleList the studies sat in a `qtlDatasets` slot, which +# an object saved then still carries as an attribute; either way they are +# rebuilt through the constructor, each one updated first. +#' @rdname updateObject-methods #' @export -setMethod("qtlDatasets", "MultiStudyQtlDataset", function(x) x@qtlDatasets) +setMethod( + "updateObject", + "MultiStudyQtlDataset", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'MultiStudyQtlDataset')") + } + studies <- attr(object, "qtlDatasets", exact = TRUE) %||% + attr(object, "listData", exact = TRUE) + sumStats <- .msqdSavedSumStats(object) + MultiStudyQtlDataset( + qtlDatasets = map(studies, updateObject, ..., verbose = verbose), + sumStats = if (is.null(sumStats)) { + NULL + } else { + updateObject(sumStats, ..., verbose = verbose) + } + ) + } +) + +# The summary statistics an object saved under any earlier definition holds, +# NULL when it holds none. slot() rather than attr(): R stores a NULL slot as +# a placeholder symbol, which attr() hands back unconverted. +# @noRd +.msqdSavedSumStats <- function(object) { + if (is.null(attr(object, "sumStats", exact = TRUE))) { + return(NULL) + } + methods::slot(object, "sumStats") +} #' @rdname sumStats #' @export @@ -266,7 +319,7 @@ setMethod("sumStats", "MultiStudyQtlDataset", function(x) x@sumStats) #' @rdname studyName #' @export setMethod("studyName", "MultiStudyQtlDataset", function(x) { - fromQtl <- names(x@qtlDatasets) + fromQtl <- names(x) fromSs <- if (is.null(x@sumStats)) { character(0) } else { @@ -275,11 +328,10 @@ setMethod("studyName", "MultiStudyQtlDataset", function(x) { unique(c(fromQtl, fromSs)) }) - #' @rdname show-methods #' @export setMethod("show", "MultiStudyQtlDataset", function(object) { - nQtl <- length(object@qtlDatasets) + nQtl <- length(object) ssEntries <- if (is.null(object@sumStats)) { 0L } else { @@ -293,7 +345,7 @@ setMethod("show", "MultiStudyQtlDataset", function(object) { if (nQtl > 0L) { cat(glue( " Individual-level studies: ", - "{str_flatten(names(object@qtlDatasets), ', ')}\n", + "{str_flatten(names(object), ', ')}\n", .trim = FALSE )) } diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 0f1a2a13..6bef1c80 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -3,10 +3,10 @@ # ----------------------------------------------------------------------------- # Single-study individual-level QTL container, built on MultiAssayExperiment: # one RangedSummarizedExperiment per QTL context, plus a `genotype` experiment -# whose assay reads lazily through a GenotypeHandle. Adds the handle itself and -# constructor-level QC knobs (mafCutoff, macCutoff, xvarCutoff, imissCutoff, -# keepVariants, keepIndel), which the genotypes / residualizedGenotypes -# accessors apply at extraction time. The entry point for individual-level +# whose assay reads lazily through a GenotypeHandle. It holds data only: the QC +# and residualization a run applies are the pipeline's settings +# (GenotypeFilterParam, ResidualizationParam), not stored here. The entry point +# for individual-level # fine-mapping (fineMappingPipeline), TWAS weight learning # (twasWeightsPipeline), and multi-study composition (MultiStudyQtlDataset). # ============================================================================= @@ -47,46 +47,12 @@ NULL #' @slot studyName Character (length 1). Study identifier; used in collection #' 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 -#' block. -#' @slot scaleResiduals Logical (length 1). Whether residualization accessors -#' scale residuals to unit variance. -#' @slot mafCutoff Numeric (length 1). Minor allele frequency threshold; -#' variants with \code{MAF < mafCutoff} are dropped at extraction time inside -#' \code{genotypes()} / \code{residualizedGenotypes()}. Default 0 (no -#' filter). -#' @slot macCutoff Numeric (length 1). Minor allele count threshold; converted -#' to a MAF threshold using \code{max(mafCutoff, macCutoff / (2 * n))} where -#' \code{n} is the post-narrowing sample count of the extracted block. Default -#' 0 (no filter). -#' @slot xvarCutoff Numeric (length 1). Per-variant genotype variance threshold; -#' variants with column variance below this are dropped at extraction time. -#' Default 0 (no filter). -#' @slot imissCutoff Numeric (length 1). Per-sample genotype-missingness -#' threshold; samples with a missing-genotype rate above this are dropped at -#' extraction time. Default 0 (no filter). -#' @slot keepVariants Character vector of variant identifiers to retain prior to -#' per-block QC. Length 0 means no restriction. -#' @slot keepIndel Logical (length 1). When \code{FALSE}, indel variants -#' (alleles that are not single nucleotides) are dropped at extraction time. -#' Default \code{TRUE}. #' @importClassesFrom MultiAssayExperiment MultiAssayExperiment #' @export setClass( "QtlDataset", contains = "MultiAssayExperiment", - representation( - studyName = "character", - scaleResiduals = "logical", - mafCutoff = "numeric", - macCutoff = "numeric", - xvarCutoff = "numeric", - imissCutoff = "numeric", - keepVariants = "character", - keepIndel = "logical" - ), - prototype = prototype(keepIndel = TRUE), + representation(studyName = "character"), validity = function(object) .validateQtlDataset(object) ) @@ -105,7 +71,7 @@ setClass( out[nms] } -# Validity for QtlDataset: scalar/cutoff slots, the phenotypes list, and +# Validity for QtlDataset: the study name, the phenotypes list, and # cross-context trait-position consistency. Returns TRUE or an error vector. # @noRd .validateQtlDataset <- function(object) { @@ -117,11 +83,9 @@ setClass( if (length(errors) == 0) TRUE else errors } -# study / scaleResiduals / keepIndel scalars + the four non-negative cutoffs. +# The study name: one non-empty string. # @noRd -#' @importFrom checkmate makeAssertCollection assertString assertLogical -#' @importFrom checkmate assertFlag assertNumber -#' @importFrom purrr walk +#' @importFrom checkmate makeAssertCollection assertString .qtlValidateScalars <- function(object) { coll <- makeAssertCollection() assertString( @@ -130,35 +94,9 @@ setClass( .var.name = "studyName", add = coll ) - assertLogical( - object@scaleResiduals, - len = 1L, - .var.name = "scaleResiduals", - add = coll - ) - assertFlag(object@keepIndel, .var.name = "keepIndel", add = coll) - walk( - c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), - .qtlValidateCutoff, - object = object, - coll = coll - ) coll$getMessages() } -# Each cutoff slot must be a single finite non-negative number. -# @noRd -#' @importFrom checkmate assertNumber -.qtlValidateCutoff <- function(nm, object, coll) { - assertNumber( - methods::slot(object, nm), - lower = 0, - finite = TRUE, - .var.name = nm, - add = coll - ) -} - # 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 @@ -253,13 +191,13 @@ setClass( as.character(c(missingGeno, noContexts)) } -# TRUE when two GRanges share canonical chrom + start + end. +# TRUE when two GRanges share chrom + start + end. # @noRd .qtlSameRange <- function(prev, this) { - isTRUE(all.equal( - canonChrom(GenomicRanges::seqnames(prev)), - canonChrom(GenomicRanges::seqnames(this)) - )) && + identical( + as.character(GenomicRanges::seqnames(prev)), + as.character(GenomicRanges::seqnames(this)) + ) && GenomicRanges::start(prev) == GenomicRanges::start(this) && GenomicRanges::end(prev) == GenomicRanges::end(this) } @@ -371,9 +309,9 @@ setClass( } # 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. +# study's genotypes: the dataset is built from the whole panel and narrowed +# afterwards (x[i, j, ]), so what it holds is not decided by which panel +# happened to be passed. # @noRd .qtlCheckWholePanel <- function(genotypes) { if (!methods::is(genotypes, "RangedSummarizedExperiment")) { @@ -386,8 +324,8 @@ setClass( } abort(glue( "'genotypes' is a subset panel ({got[[1L]]} x {got[[2L]]} of ", - "{full[[1L]]} x {full[[2L]]}); pass the whole panel and narrow with ", - "'keepVariants' / 'keepSamples' instead." + "{full[[1L]]} x {full[[2L]]}); pass the whole panel and subset the ", + "QtlDataset afterwards, with x[i, j, ]." )) } @@ -408,32 +346,14 @@ setClass( #' @param genotypeCovariates Numeric matrix of genotype-derived covariates #' (e.g., ancestry PCs); rows are samples. Becomes the \code{colData} of the #' genotype experiment. -#' @param scaleResiduals Logical (length 1). Default \code{TRUE}. -#' @param genotypeFilterParam Which variants and samples to keep, built with -#' \code{\link{GenotypeFilterParam}}. A bare list is refused, since it -#' cannot be checked. Each field is recorded on the object and applied -#' lazily, at extraction time inside \code{genotypes()} / -#' \code{residualizedGenotypes()}: -#' \itemize{ -#' \item \code{mafCutoff} --- drop variants with -#' \code{MAF < mafCutoff}. Unset means 0 (no filter). -#' \item \code{macCutoff} --- a minor-allele-count threshold, converted -#' to a MAF threshold as \code{max(mafCutoff, macCutoff / (2 * n))} -#' with \code{n} the post-narrowing sample count of the extracted -#' block. Unset means 0. -#' \item \code{xvarCutoff} --- drop variants whose column variance is -#' below this. Unset means 0. -#' \item \code{imissCutoff} --- drop samples whose missing-genotype rate -#' exceeds this. Unset means 0. -#' \item \code{keepSamples} --- subset the dataset to these samples, -#' narrowing \code{colData} and \code{sampleMap} together so the -#' sample set has one home rather than two. Unset, or -#' \code{character(0)}, means no restriction. -#' \item \code{keepVariants} --- retain only these variants, before -#' per-block QC. Unset, or \code{character(0)}, means no restriction. -#' \item \code{keepIndel} --- when \code{FALSE}, drop variants whose -#' alleles are not single nucleotides. Unset means \code{TRUE}. -#' } +#' @details A \code{QtlDataset} holds data only. Which variants and samples +#' an analysis keeps, and whether residuals are scaled, are the pipeline's +#' settings (\code{\link{GenotypeFilterParam}} and +#' \code{\link{ResidualizationParam}} on \code{\link{fineMappingPipeline}}, +#' \code{\link{twasWeightsPipeline}} and \code{\link{colocboostPipeline}}), +#' applied per extracted block. To work with part of the data, subset the +#' dataset itself: \code{x[i, j, k]} narrows features, samples and +#' contexts. #' @return A \code{QtlDataset} object. #' @examples #' panel <- readGenotypes( @@ -458,42 +378,31 @@ QtlDataset <- function( studyName, genotypes, phenotypes, - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam() + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) ) { - .assertMethodParam( - genotypeFilterParam, - "GenotypeFilterParam" - ) - filt <- .qtlResolveFilter(genotypeFilterParam) handle <- .qtlValidateInputs(phenotypes, genotypes) - experiments <- c( - set_names( - list(.genotypeExperiment(genotypes, genotypeCovariates)), - .QTL_GENO_EXPERIMENT + # Every experiment's rowRanges in UCSC style, so the dataset's traits and + # variants meet every other range pecotmr holds exactly. + experiments <- map( + c( + set_names( + list(.genotypeExperiment(genotypes, genotypeCovariates)), + .QTL_GENO_EXPERIMENT + ), + as.list(phenotypes) ), - as.list(phenotypes) + .ucscExperiment ) mae <- MultiAssayExperiment::MultiAssayExperiment( experiments = experiments, colData = .qtlPrimaryColData(experiments), sampleMap = .qtlSampleMap(experiments) ) - obj <- methods::new( + methods::new( "QtlDataset", - .qtlRestrictSamples(mae, filt$keepSamples), - studyName = as.character(studyName), - scaleResiduals = isTRUE(scaleResiduals), - mafCutoff = as.numeric(filt$mafCutoff), - macCutoff = as.numeric(filt$macCutoff), - xvarCutoff = as.numeric(filt$xvarCutoff), - imissCutoff = as.numeric(filt$imissCutoff), - keepVariants = as.character(filt$keepVariants), - keepIndel = isTRUE(filt$keepIndel) + mae, + studyName = as.character(studyName) ) - validObject(obj) - obj } #' @describeIn QtlDataset-class Subset by feature, sample and experiment. @@ -746,10 +655,6 @@ setMethod("genotypeCovariates", "QtlDataset", function(x) { `rownames<-`(as.matrix(as.data.frame(cd)), rownames(cd)) } -#' @rdname scaleResiduals -#' @export -setMethod("scaleResiduals", "QtlDataset", function(x) x@scaleResiduals) - #' @rdname genotypeHandle #' @keywords internal setMethod("genotypeHandle", "QtlDataset", function(x) { @@ -762,37 +667,13 @@ setMethod("genotypeHandle", "QtlDataset", function(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 +# panel's own ids), CHR, 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) - -#' @rdname qtlDatasetFilters -#' @export -setMethod("macCutoff", "QtlDataset", function(x) x@macCutoff) - -#' @rdname qtlDatasetFilters -#' @export -setMethod("xvarCutoff", "QtlDataset", function(x) x@xvarCutoff) - -#' @rdname qtlDatasetFilters -#' @export -setMethod("imissCutoff", "QtlDataset", function(x) x@imissCutoff) - -#' @rdname qtlDatasetFilters -#' @export -setMethod("keepVariants", "QtlDataset", function(x) x@keepVariants) - -#' @rdname qtlDatasetFilters -#' @export -setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) - # --- Internal: resolve the variant-selection region for the genotype handle. # Returns a GRanges (one or more ranges). When `traitId` is supplied, expand # each trait's rowRange by `cisWindow` bp and take the union span (per the @@ -823,7 +704,7 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) # none of them. # @noRd .qtlTraitRangesInContext <- function(ctx, x, traitId) { - se <- molecularTraits(x, ctx) + se <- .qtlContextSe(x, ctx) hits <- .qtlPresentIndices(traitId, rownames(se)) if (length(hits) == 0L) { return(NULL) @@ -879,9 +760,8 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) # A literal `region` GRanges, each range optionally extended by cisWindow. # @noRd #' @importFrom checkmate assertNumber -#' @importFrom checkmate assertClass .qtlLiteralRegion <- function(region, cisWindow) { - assertClass(region, "GRanges") + region <- .assertRegionGRanges(region) if (length(region) == 0L) { abort("`region` must contain at least one range.") } @@ -900,8 +780,8 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) # Per-trait genomic position: each trait's OWN rowRanges span across contexts # (union min-start to max-end), WITHOUT the cisWindow expansion. One range per -# traitId (a 0-width chrUn sentinel for a trait absent from every context), for -# threading trait-position provenance onto QtlFineMappingResult / TwasWeights. +# traitId; a trait absent from every context is an error, as a lookup by an +# unknown name is for rowRanges(). # @noRd .qtlTraitPos <- function(x, traitIds) { # Extract chrom/start/end as plain vectors per trait (union span across @@ -909,6 +789,13 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) # GRanges with do.call(c, .) can trip S4 seqinfo reconciliation in some # GenomeInfoDb builds, so we avoid it entirely. spans <- map(traitIds, .qtlTraitSpan, x = x, contexts = contexts(x)) + absent <- traitIds[map_lgl(spans, is.null)] + if (length(absent) > 0L) { + abort(glue( + "traitPosition: trait(s) in no context of this QtlDataset: ", + "{str_flatten(absent, ', ')}." + )) + } starts <- map_int(spans, "start") # `set_names()` is vector-only, so name the GRanges through `names<-` # applied as a function -- still a copy, no binding rewritten. @@ -941,7 +828,7 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) traitId = tid )) if (length(ranges) == 0L) { - return(list(chr = "chrUn", start = 1L, end = 1L)) + return(NULL) } chrs <- map_chr(ranges, .qtlFirstSeqname) list( @@ -963,11 +850,11 @@ setMethod("keepIndel", "QtlDataset", function(x) x@keepIndel) #' @rdname traitPosition #' @export -setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { - tids <- if (is.null(traitId)) { +setMethod("traitPosition", "QtlDataset", function(x, trait = NULL) { + tids <- if (is.null(trait)) { unique(list_c(map(.qtlPhenotypeList(x), rownames))) } else { - as.character(traitId) + as.character(trait) } .qtlTraitPos(x, tids) }) @@ -983,7 +870,7 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { } siChr <- variants$CHR bp <- variants$BP - rChr <- canonChrom(GenomicRanges::seqnames(region)) + rChr <- as.character(GenomicRanges::seqnames(region)) rStart <- GenomicRanges::start(region) rEnd <- GenomicRanges::end(region) if (length(region) == 0L) { @@ -1006,19 +893,14 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { which(siChr == rChr[i] & bp >= rStart[i] & bp <= rEnd[i]) } -# Internal: keepIndel slot read, tolerant of QtlDataset objects serialized -# before the slot existed (treat a missing slot as TRUE = keep indels). -#' @importFrom purrr possibly -.qtlKeepIndel <- function(x) { - isTRUE(possibly(keepIndel, otherwise = TRUE)(x)) -} - -# A GenotypeFilterParam() bundle with every field resolved. Unset fields -# (absent from the bundle) take this constructor's documented defaults -- -# which is what makes the same bundle usable as a specification here and as an -# override in .qtlApplyFilterOverrides, where unset means "leave the slot". +# A GenotypeFilterParam() bundle with every field resolved: an unset field +# (absent from the bundle) takes its default -- 0 for each cutoff, no +# restriction for each keep-list, TRUE for keepIndel. This is the form a +# pipeline threads to every extraction it makes; a dataset records no filter +# of its own, so the accessors extract with the all-default one. # @noRd -.qtlResolveFilter <- function(genotypeFilterParam) { +.qtlResolveFilter <- function(genotypeFilterParam = GenotypeFilterParam()) { + .assertMethodParam(genotypeFilterParam, "GenotypeFilterParam") list( mafCutoff = genotypeFilterParam$mafCutoff %||% 0, macCutoff = genotypeFilterParam$macCutoff %||% 0, @@ -1030,78 +912,25 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { ) } -# Coerce an override, preserving "unset" as NULL. Hoisted rather than written -# inline three times, and not nested, per the package's no-nested-functions -# rule. -# @noRd -.qtlNumOverride <- function(x) { - if (is.null(x)) NULL else as.numeric(x) -} - -# @noRd -.qtlLglOverride <- function(x) { - if (is.null(x)) NULL else as.logical(x) -} - -# @noRd -.qtlChrOverride <- function(x) { - if (is.null(x)) NULL else as.character(x) -} - -# Internal: return a copy of a QtlDataset with the supplied filter cutoffs / -# keep-lists REPLACING the stored slot values (NULL = leave the stored value -# untouched). This lets a pipeline accept per-call filter overrides as ordinary -# arguments instead of forcing callers to mutate @slots directly (which bypasses -# the class's validity checks). Applied against a validated copy. -.qtlApplyFilterOverrides <- function(data, genotypeFilterParam) { - .assertMethodParam( - genotypeFilterParam, - "GenotypeFilterParam" - ) - # discard(is.null), not compact(): a keepVariants of character(0) is a - # real instruction ("restrict to nothing was not asked, keep all"), and - # compact() would drop it along with the unset fields. - overridden <- exec( - methods::initialize, - data, - !!!discard( - list( - mafCutoff = .qtlNumOverride(genotypeFilterParam$mafCutoff), - macCutoff = .qtlNumOverride(genotypeFilterParam$macCutoff), - xvarCutoff = .qtlNumOverride(genotypeFilterParam$xvarCutoff), - imissCutoff = .qtlNumOverride(genotypeFilterParam$imissCutoff), - keepIndel = .qtlLglOverride(genotypeFilterParam$keepIndel), - keepVariants = .qtlChrOverride(genotypeFilterParam$keepVariants) - ), - is.null - ) - ) - keepSamples <- genotypeFilterParam$keepSamples - restricted <- if (is.null(keepSamples)) { - overridden - } else { - .qtlRestrictSamples(overridden, keepSamples) - } - methods::validObject(restricted) - restricted -} - -# Drop samples whose missingness across the block exceeds the dataset's +# Drop samples whose missingness across the block exceeds the filter's # imissCutoff. A cutoff of 0 (or an empty block) keeps every sample. # @noRd -.qtlDropMissingSamples <- function(dosage, x) { - if (imissCutoff(x) <= 0 || nrow(dosage) == 0L || ncol(dosage) == 0L) { +.qtlDropMissingSamples <- function(dosage, filter) { + cutoff <- filter$imissCutoff + if (cutoff <= 0 || nrow(dosage) == 0L || ncol(dosage) == 0L) { return(dosage) } - dosage[rowMeans(is.na(dosage)) <= imissCutoff(x), , drop = FALSE] + dosage[rowMeans(is.na(dosage)) <= cutoff, , drop = FALSE] } -# Internal: extract the panel dosage block (samples x variants) for the -# requested region, narrow to the requested sample set, and apply lazy QC -# (per-sample imiss filter, then per-variant max(mafCutoff, -# macCutoff / (2 * n)) and xvarCutoff filters). Used by genotypes, -# residualizedGenotypes (via genotypes), and maf so all three -# share a single variant/sample selection result. +# Internal: extract the dosage block (samples x variants) for the variants +# in `window` (every variant when NULL), narrow to `samples`, and apply the +# resolved genotype `filter` (.qtlResolveFilter()): per-sample imiss, then +# per-variant max(mafCutoff, macCutoff / (2 * n)) and xvarCutoff. The +# accessors extract the whole dataset with the all-default filter; a +# pipeline passes the window, samples and filter its run settled on, so +# genotypes, allele frequencies and residualized genotypes share one +# selection. # # Returns a list: # geno : numeric matrix (kept samples x kept variants) @@ -1115,24 +944,25 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { # is `pmin(af, 1 - af)`. .qtlExtractBlock <- function( x, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL + window = NULL, + samples = NULL, + filter = .qtlResolveFilter() ) { - gr <- .qtlResolveVariantRegion( - x, - traitId = traitId, - region = region, - cisWindow = cisWindow - ) - inRegion <- .qtlVariantIndices(x, gr) + # A pipeline threads its resolved filter to every extraction; a NULL one + # means a call site was missed, which must not pass for "no filter". + if (!is.list(filter) || is.null(filter$mafCutoff)) { + abort( + "No resolved genotype filter reached this extraction.", + .internal = TRUE + ) + } + inRegion <- .qtlVariantIndices(x, window) if (length(inRegion) == 0L) { return(.qtlEmptyBlockAllSamples(x)) } # Apply keepVariants + indel restrictions before materialization so we do # not extract dosage we would immediately drop. - snpIdx <- .qtlNarrowSnpIdx(x, inRegion) + snpIdx <- .qtlNarrowSnpIdx(x, inRegion, filter) if (length(snpIdx) == 0L) { return(.qtlEmptyBlock()) } @@ -1147,7 +977,10 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { return(.qtlEmptyBlockNoSamples(dosage)) } kept <- dosage[keep, , drop = FALSE] - filtered <- .qtlVariantFilters(.qtlDropMissingSamples(kept, x), x) + filtered <- .qtlVariantFilters( + .qtlDropMissingSamples(kept, filter), + filter + ) imputed <- .qtlMeanImpute(filtered$dosage) list( geno = imputed, @@ -1208,16 +1041,16 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { # Narrow the selected variant indices by keepVariants (matched by chrom/pos/ # allele) and, unless kept, by dropping indels. Done before materialization. # @noRd -.qtlNarrowSnpIdx <- function(x, snpIdx) { +.qtlNarrowSnpIdx <- function(x, snpIdx, filter) { si <- .qtlGenotypeVariants(x) - kept <- if (length(keepVariants(x)) == 0L) { + kept <- if (length(filter$keepVariants) == 0L) { snpIdx } else { snpAll <- si$SNP[snpIdx] - km <- matchVariants(snpAll, as.character(keepVariants(x))) + km <- matchVariants(snpAll, as.character(filter$keepVariants)) snpIdx[replace(logical(length(snpAll)), km$idxA, TRUE)] } - if (length(kept) == 0L || .qtlKeepIndel(x)) { + if (length(kept) == 0L || isTRUE(filter$keepIndel)) { return(kept) } # which() (not the mask) so an NA mask drops the variant rather than @@ -1249,7 +1082,7 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { # gives directional `af`; `maf` folds to the minor allele). Returns # list(dosage, maf, af). # @noRd -.qtlVariantFilters <- function(dosage, x) { +.qtlVariantFilters <- function(dosage, filter) { # No zero-variant guard: the only caller returns early when snpIdx is # empty, and extraction preserves the column count (.restoreRequestedOrder # aborts on a mismatch). The body is 0-column safe regardless -- colSums @@ -1261,11 +1094,11 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { afVec <- p mafVec <- pmin(p, 1 - p) effectiveMaf <- max( - mafCutoff(x), - if (nSamp > 0L) macCutoff(x) / (2 * nSamp) else 0 + filter$mafCutoff, + if (nSamp > 0L) filter$macCutoff / (2 * nSamp) else 0 ) byMaf <- !is.na(mafVec) & mafVec >= effectiveMaf - keepVarMask <- if (xvarCutoff(x) <= 0 || nSamp <= 1L) { + keepVarMask <- if (filter$xvarCutoff <= 0 || nSamp <= 1L) { byMaf } else { mu <- if_else(nObs > 0L, sumD / nObs, 0) @@ -1277,7 +1110,7 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { 0 ) varVec <- colSums(centered * centered) / (nSamp - 1L) - byMaf & varVec >= xvarCutoff(x) + byMaf & varVec >= filter$xvarCutoff } list( dosage = dosage[, keepVarMask, drop = FALSE], @@ -1304,105 +1137,74 @@ setMethod("traitPosition", "QtlDataset", function(x, traitId = NULL) { #' @rdname genotypes #' @export -setMethod( - "genotypes", - "QtlDataset", - function( - x, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL - ) { - .qtlExtractBlock( - x, - traitId = traitId, - region = region, - cisWindow = cisWindow, - samples = samples - )$geno - } -) +setMethod("genotypes", "QtlDataset", function(x) { + # The whole dataset, unfiltered: narrow it first with x[i, j, ]. + .qtlExtractBlock(x)$geno +}) #' @rdname maf #' @export -setMethod( - "maf", - "QtlDataset", - function(x, region = NULL, cisWindow = NULL, samples = NULL) { - block <- .qtlExtractBlock( - x, - traitId = NULL, - region = region, - cisWindow = cisWindow, - samples = samples - ) - set_names(block$maf, block$variantIds) - } -) +setMethod("maf", "QtlDataset", function(x) { + block <- .qtlExtractBlock(x) + set_names(block$maf, block$variantIds) +}) #' @rdname af #' @export -setMethod( - "af", - "QtlDataset", - function( - x, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL - ) { - block <- .qtlExtractBlock( - x, - traitId = traitId, - region = region, - cisWindow = cisWindow, - samples = samples - ) - set_names(block$af, block$variantIds) - } -) +setMethod("af", "QtlDataset", function(x) { + block <- .qtlExtractBlock(x) + set_names(block$af, block$variantIds) +}) #' @rdname molecularTraits #' @export setMethod( "molecularTraits", "QtlDataset", - function( - x, - contexts, - traitId = NULL, - region = NULL, - naAction = c("keep", "drop", "impute"), - outlierAction = c("keep", "drop"), - outlierPvalThreshold = 1e-3, - outlierArgs = CovMcdOptions() - ) { - naAction <- arg_match(naAction) - outlierAction <- arg_match(outlierAction) - .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") - .qtlValidateContexts(x, contexts) - out <- .qtlPhenotypeList(x)[contexts] |> - .qtlFilterPhenotypes( - contexts, - traitId, - region, - naAction, - outlierAction, - outlierPvalThreshold, - outlierArgs - ) - if (length(contexts) == 1L) out[[1L]] else out + function(x, context, trait = NULL) { + .qtlMolecularTraits(x, context, trait) } ) +# molecularTraits() for the pipelines, which may also keep only the traits +# positioned inside an analysis `window` (a GRanges) and apply the run's +# resolved phenotype QC (.qtlResolvePhenotypeFilter()). The accessor passes +# neither, so it returns the data as stored. Always a list keyed by context. +# @noRd +.qtlMolecularTraits <- function( + x, + contexts, + traitId = NULL, + window = NULL, + phenotypeFilter = .qtlKeepAllPhenotypes() +) { + .qtlValidateContexts(x, contexts) + .qtlPhenotypeList(x)[contexts] |> + .qtlFilterPhenotypes( + contexts, + traitId, + window, + phenotypeFilter$naAction, + phenotypeFilter$outlierAction, + phenotypeFilter$outlierPvalThreshold, + phenotypeFilter$outlierArgs + ) +} + +# One context's phenotype SummarizedExperiment as stored, for the internal +# callers that hold a single context name and read its traits or ranges. +# @noRd +.qtlContextSe <- function(x, context) { + .qtlValidateContexts(x, context) + .qtlPhenotypeList(x)[[context]] +} + # `contexts` is required and must all be known phenotype contexts. # @noRd .qtlValidateContexts <- function(x, contexts) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { msg <- glue( - "`contexts` is required for molecularTraits(QtlDataset). Pass a ", + "`context` is required for molecularTraits(QtlDataset). Pass a ", "character vector of one or more context names; use ", "contexts(x) to list the available contexts." ) @@ -1432,14 +1234,14 @@ setMethod( set_names(filtered, contexts) } -# Apply the optional trait / region / NA / outlier filters to the per-context +# Apply the optional trait / window / NA / outlier filters to the per-context # phenotype SEs. # @noRd .qtlFilterPhenotypes <- function( out, contexts, traitId, - region, + window, naAction, outlierAction, outlierPvalThreshold, @@ -1450,10 +1252,17 @@ setMethod( } else { .qtlFilterTraits(out, contexts, traitId) } - inRegion <- if (is.null(region)) { + inRegion <- if (is.null(window)) { byTrait } else { - set_names(map(byTrait, .qtlSeInRegion, region = region), contexts) + set_names( + map( + byTrait, + .qtlSeInRegion, + region = .assertRegionGRanges(window, "`window`") + ), + contexts + ) } naHandled <- if (naAction == "keep") { inRegion @@ -1570,29 +1379,47 @@ CovMcdOptions <- function(...) { # robustbase's MCD when it is installed and converges, else the non-robust # colMeans/cov pair. Both fallbacks are announced -- a silently non-robust # estimate would make the outlier rule mean something different from what -# the caller asked for. +# the caller asked for. `singularReported` records that robustbase has +# already warned its MCD covariance is singular, so the caller does not say +# it a second time. # @noRd #' @importFrom rlang try_fetch .qtlOutlierCenterCov <- function(Y, outlierArgs = list()) { # Engine-call exception: robustbase::covMcd is a covariance estimator, # interchangeable with the colMeans/stats::cov fallback above -- a numeric # primitive for outlier detection while a QtlDataset is built. + fallback <- list( + center = colMeans(Y), + cov = stats::cov(Y), + singularReported = FALSE + ) if (!requireNamespace("robustbase", quietly = TRUE)) { msg <- glue( "outlier detection: install 'robustbase' for an MCD-based ", "estimator; falling back to non-robust colMeans/cov." ) inform(msg) - return(list(center = colMeans(Y), cov = stats::cov(Y))) + return(fallback) } mcd <- try_fetch( exec(robustbase::covMcd, Y, !!!as.list(outlierArgs)), - error = function(cnd) NULL + error = function(cnd) { + msg <- glue( + "outlier detection: robustbase's MCD estimator failed; ", + "falling back to non-robust colMeans/cov." + ) + inform(msg, parent = cnd) + NULL + } ) if (is.null(mcd)) { - return(list(center = colMeans(Y), cov = stats::cov(Y))) + return(fallback) } - list(center = mcd$center, cov = mcd$cov) + list( + center = mcd$center, + cov = mcd$cov, + singularReported = !is.null(mcd$singularity) + ) } # Significance: per-sample chi-squared(p) p-value with Bonferroni @@ -1624,11 +1451,15 @@ CovMcdOptions <- function(...) { invCov <- try_fetch( solve(covMat), error = function(cnd) { - msg <- glue( - "outlier detection: the trait covariance is singular; ", - "using a Moore-Penrose pseudo-inverse instead." - ) - inform(msg, parent = cnd) + # When robustbase has already warned that its covariance is + # singular, that warning is the one signal the caller gets. + if (!est$singularReported) { + msg <- glue( + "outlier detection: the trait covariance is singular; ", + "using a Moore-Penrose pseudo-inverse instead." + ) + inform(msg, parent = cnd) + } MASS::ginv(covMat) } ) @@ -1661,31 +1492,29 @@ CovMcdOptions <- function(...) { #' @rdname phenotypeCovariates #' @export -setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { - if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { - abort("`contexts` is required.") +setMethod("phenotypeCovariates", "QtlDataset", function(x, context) { + if (missing(context) || is.null(context) || length(context) == 0L) { + abort("`context` is required.") } available <- contexts(x) - bad <- setdiff(contexts, available) + bad <- setdiff(context, available) if (length(bad) > 0L) { msg <- glue("Unknown context(s): {str_flatten(bad, ', ')}") abort(msg) } - set_names(map(contexts, .qtlContextColData, x = x), contexts) + set_names(map(context, .qtlContextColData, x = x), context) }) -# Whether to scale residual columns to unit variance: the per-call override -# when the bundle sets one, else the dataset's own slot. +# Whether to scale residual columns to unit variance: what the bundle sets, +# else TRUE -- the run's setting, since a dataset records none. A NULL bundle +# answers NULL for the field, so it resolves to TRUE as well. # # Unset (NULL) rather than FALSE means "not asked", the same three-state # convention `residualizePhenotype` / `residualizeGenotype` use -- a flat # formal defaulting to TRUE could not tell "FALSE" from "not given". # @noRd -.qtlScaleResiduals <- function(x, residualizationParam) { - if (is.null(residualizationParam)) { - return(scaleResiduals(x)) - } - residualizationParam$scaleResiduals %||% scaleResiduals(x) +.qtlScaleResiduals <- function(residualizationParam) { + residualizationParam$scaleResiduals %||% TRUE } # Internal: residualize a numeric matrix Y (n x k) against a covariate @@ -1696,6 +1525,11 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { # column to unit standard deviation; constant-valued columns are left # unchanged. .qtlResidualizeQr <- function(Y, C, scaleResiduals = TRUE) { + # A trait filter that keeps none of a context's traits leaves nothing to + # residualize; lm.fit() cannot take a zero-column response. + if (ncol(Y) == 0L) { + return(Y) + } X <- if (is.null(C) || ncol(C) == 0L) { matrix( 1, @@ -1732,7 +1566,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { # all available covariates; otherwise validate the requested names are present. # @noRd .qtlResolveOne <- function(ctx, requested, x) { - se <- molecularTraits(x, ctx) + se <- .qtlContextSe(x, ctx) avail <- colnames(SummarizedExperiment::colData(se)) if (is.null(requested)) { return(avail) @@ -1801,7 +1635,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(badKeys) > 0L) { msg <- glue( "`phenotypeCovariates`: list key(s) not in ", - "`contexts`: {str_flatten(badKeys, ', ')}" + "`context`: {str_flatten(badKeys, ', ')}" ) abort(msg) } @@ -1809,8 +1643,8 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(missingKeys) > 0L) { msg <- glue( "`phenotypeCovariates`: list does not cover all ", - "`contexts`. Per-context lists must have exactly the same context ", - "set as `contexts`. Missing keys: ", + "`context`. Per-context lists must have exactly the same context ", + "set as `context`. Missing keys: ", "{str_flatten(missingKeys, ', ')}" ) abort(msg) @@ -1912,7 +1746,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { if (length(keep) == 0L) { return(NULL) } - se <- molecularTraits(x, ctx) + se <- .qtlContextSe(x, ctx) cd <- as.matrix(as.data.frame(SummarizedExperiment::colData(se))) block <- cd[, keep, drop = FALSE] `colnames<-`(block, str_c(ctx, ".", colnames(block))) @@ -2013,18 +1847,22 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { list(G = G[common, , drop = FALSE], C = C[common, , drop = FALSE]) } -.qtlResidualizedGenotypesImpl <- function( +# residualizedGenotypes() for the pipelines: the genotypes of `window` and +# `samples` under the run's resolved genotype `filter`, residualized on the +# covariates of `contexts`. The accessor passes the whole dataset and the +# all-default filter. +# @noRd +.qtlResidualizedGenotypes <- function( x, contexts, - traitId = NULL, - region = NULL, - cisWindow = NULL, + window = NULL, samples = NULL, + filter = .qtlResolveFilter(), residualizationParam = ResidualizationParam() ) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { msg <- glue( - "`contexts` is required for ", + "`context` is required for ", "residualizedGenotypes(QtlDataset). ", "Use contexts(x) to list the available contexts. ", "Pass a single context for per-context mode or multiple ", @@ -2041,13 +1879,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { msg <- glue("Unknown context(s): {str_flatten(bad, \', \')}") abort(msg) } - G <- genotypes( - x, - traitId = traitId, - region = region, - cisWindow = cisWindow, - samples = samples - ) + G <- .qtlExtractBlock(x, window, samples, filter)$geno if (ncol(G) == 0L) { return(G) } @@ -2056,7 +1888,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = .qtlScaleResiduals(x, residualizationParam) + scaleResiduals = .qtlScaleResiduals(residualizationParam) ) } @@ -2065,27 +1897,29 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { setMethod( "residualizedGenotypes", "QtlDataset", - .qtlResidualizedGenotypesImpl + function(x, context, residualizationParam = ResidualizationParam()) { + .qtlResidualizedGenotypes( + x, + context, + residualizationParam = residualizationParam + ) + } ) -# NA-handled raw phenotypes per context (re-wrapped to a list so single- and -# multi-context callers see the same shape). +# NA-handled raw phenotypes, a list keyed by context. # @noRd -.qtlResidPhenoY <- function(x, contexts, traitId, region, naAction) { - fetched <- molecularTraits( +.qtlResidPhenoY <- function(x, contexts, traitId, window, naAction) { + # Missing values only: outliers are judged on the residualized values. + .qtlMolecularTraits( x, contexts = contexts, traitId = traitId, - region = region, - naAction = naAction + window = window, + phenotypeFilter = list_modify( + .qtlKeepAllPhenotypes(), + naAction = naAction + ) ) - # A single context returns the bare matrix rather than a named list. - Yraw <- if (length(contexts) == 1L) { - set_names(list(fetched), contexts) - } else { - fetched - } - Yraw } # Phenotype and covariate matrices restricted to the samples they share. @@ -2138,27 +1972,23 @@ setMethod( allRes[keep, , drop = FALSE] } -# residualizedPhenotypes worker: resolve covariate inclusion + selections, +# residualizedPhenotypes() worker: resolve covariate inclusion + selections, # NA-handle Y, build the covariate design, and per-context residualize + -# outlier-filter. `p` holds the setMethod args + precomputed missing() flags. +# outlier-filter, under the run's resolved phenotype QC. The pipelines may +# also keep only the traits inside an analysis `window`; the accessor passes +# no window and no QC. Always a list keyed by context. # @noRd -.qtlResidualizedPhenotypesImpl <- function( +.qtlResidualizedPhenotypes <- function( x, contexts, traitId = NULL, - region = NULL, - naAction = c("keep", "drop", "impute"), - outlierAction = c("keep", "drop"), - outlierPvalThreshold = 1e-3, - outlierArgs = CovMcdOptions(), + window = NULL, + phenotypeFilter = .qtlKeepAllPhenotypes(), residualizationParam = ResidualizationParam() ) { if (missing(contexts) || is.null(contexts) || length(contexts) == 0L) { - abort("`contexts` is required for residualizedPhenotypes().") + abort("`context` is required for residualizedPhenotypes().") } - naAction <- arg_match(naAction) - outlierAction <- arg_match(outlierAction) - .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") .assertMethodParam( residualizationParam, "ResidualizationParam" @@ -2173,18 +2003,18 @@ setMethod( x, contexts, traitId, - region, - naAction + window, + phenotypeFilter$naAction ) .qtlResidPerContext( contexts, Yraw = Yraw, C = C, x = x, - outlierAction = outlierAction, - outlierPvalThreshold = outlierPvalThreshold, - outlierArgs = outlierArgs, - scaleResiduals = .qtlScaleResiduals(x, residualizationParam) + outlierAction = phenotypeFilter$outlierAction, + outlierPvalThreshold = phenotypeFilter$outlierPvalThreshold, + outlierArgs = phenotypeFilter$outlierArgs, + scaleResiduals = .qtlScaleResiduals(residualizationParam) ) } @@ -2193,7 +2023,19 @@ setMethod( setMethod( "residualizedPhenotypes", "QtlDataset", - .qtlResidualizedPhenotypesImpl + function( + x, + context, + trait = NULL, + residualizationParam = ResidualizationParam() + ) { + .qtlResidualizedPhenotypes( + x, + context, + trait, + residualizationParam = residualizationParam + ) + } ) # What the phenotypes are regressed against: resolve the convenience vs @@ -2241,7 +2083,7 @@ setMethod( outlierArgs, scaleResiduals ) { - out <- set_names( + set_names( map( contexts, .qtlResidualizeContext, @@ -2255,7 +2097,6 @@ setMethod( ), contexts ) - if (length(contexts) == 1L) out[[1L]] else out } #' @rdname show-methods @@ -2287,7 +2128,6 @@ setMethod("show", "QtlDataset", function(object) { " Samples: {nrow(MultiAssayExperiment::colData(object))}\n", .trim = FALSE )) - cat(glue(" Scale residuals: {object@scaleResiduals}\n", .trim = FALSE)) }) # ---- map/apply helpers (lambda-free callbacks) --------------------------- @@ -2309,17 +2149,24 @@ setMethod("show", "QtlDataset", function(object) { se[present, , drop = FALSE] } -# One context's SE restricted to features overlapping `region`. +# One context's SE restricted to features overlapping `region`. A context with +# no trait on the window's chromosomes keeps none, decided before +# overlapsAny(), which would warn that the two share no seqlevel. # @noRd .qtlSeInRegion <- function(se, region) { rr <- SummarizedExperiment::rowRanges(se) + if ( + !any(is_in(as.character(seqnames(rr)), as.character(seqnames(region)))) + ) { + return(se[integer(0), , drop = FALSE]) + } se[IRanges::overlapsAny(rr, region), , drop = FALSE] } # One context's covariate matrix (colData of its phenotype SE). # @noRd .qtlContextColData <- function(ctx, x) { - se <- molecularTraits(x, ctx) + se <- .qtlContextSe(x, ctx) cd <- SummarizedExperiment::colData(se) as.matrix(as.data.frame(cd)) } @@ -2340,7 +2187,7 @@ setMethod("show", "QtlDataset", function(object) { outlierAction, outlierPvalThreshold, outlierArgs = list(), - scaleResiduals = scaleResiduals(x) + scaleResiduals = TRUE ) { .qtlResidualizeContextPheno( Yraw[[ctx]], @@ -2414,12 +2261,10 @@ setClass( #' covariates. \code{NULL} (default) means unset, read as \code{TRUE}. #' @param scaleResiduals Logical. Scale each residual column to unit #' variance, which is what puts a fitted effect on the standardized -#' genotype scale. \code{NULL} (default) means unset, and the accessors -#' fall back to the dataset's own \code{\link{scaleResiduals}} slot -#' (itself \code{TRUE} by default) --- so this is the per-call override of -#' a per-object default, and the only knob the pipelines need: it reaches -#' \code{\link{residualizedGenotypes}} already, which is the one point -#' every individual-level fit draws its genotypes through. +#' genotype scale. \code{NULL} (default) means unset, read as +#' \code{TRUE}. It is the only scale knob the pipelines need: it reaches +#' \code{\link{residualizedGenotypes}}, the one point every +#' individual-level fit draws its genotypes through. #' @param covariateNaAction How missing covariate values are handled when the #' design is assembled: \code{"impute"} or \code{"drop"}. \code{NULL} #' (default) leaves the accessor's own default in place. @@ -2450,6 +2295,62 @@ ResidualizationParam <- function( ) } +# Slots a QtlDataset held before its run settings moved to the pipelines' +# Params (GenotypeFilterParam, ResidualizationParam). An object saved then +# still carries them as attributes, which updateObject() drops. +# @noRd +.QTL_RETIRED_SLOTS <- c( + "scaleResiduals", + "mafCutoff", + "macCutoff", + "xvarCutoff", + "imissCutoff", + "keepVariants", + "keepIndel" +) + +# A QtlDataset saved before its study's slot was named `studyName` holds it +# as `study`; one saved with run settings has them dropped +# (.QTL_RETIRED_SLOTS); and its genotype panel is brought up to date +# (.qtlUpdateGenotypes()). +#' @rdname updateObject-methods +#' @export +setMethod("updateObject", "QtlDataset", function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'QtlDataset')") + } + trimmed <- reduce( + .QTL_RETIRED_SLOTS, + .qtlDropAttribute, + .init = .renameSavedSlots(object, c(study = "studyName")) + ) + # Updated here, not as callNextMethod()'s argument: the inherited update + # first reads its argument inside try(), so an error there would be + # swallowed and the update run a second time. + updated <- .qtlUpdateGenotypes(trimmed) + methods::callNextMethod(updated, ..., verbose = verbose) +}) + +# @noRd +.qtlDropAttribute <- function(object, nm) { + attr(object, nm) <- NULL + object +} + +# A dataset whose genotype panel was saved before panels took today's shape +# has it read again (.updatePanel()). Unlike an LD reference it cannot be +# kept as saved when that fails -- the dataset is nothing without its +# genotypes -- so the error stands. +# @noRd +.qtlUpdateGenotypes <- function(x) { + panel <- .qtlGenotypeSe(x) + updated <- .updatePanel(panel) + if (identical(updated, panel)) { + return(x) + } + .qtlWithGenotypeHandle(x, updated) +} + #' @rdname GenotypeFilterParam #' @aliases GenotypeFilterParam-class #' @exportClass GenotypeFilterParam @@ -2469,29 +2370,25 @@ setClass( #' @title Genotype Filtering Options #' @description Which variants and samples survive when a genotype matrix is -#' assembled, as one checked bundle. Used by \code{\link{QtlDataset}}, the -#' manifest loaders, and the pipelines that build a dataset. -#' @section Unset versus set: -#' Every field defaults to \code{NULL}, meaning \strong{not set}, and an -#' unset field is absent from the result rather than carried as \code{NULL}. -#' That is what lets one bundle serve two roles: -#' \itemize{ -#' \item to \code{\link{QtlDataset}} it is a \emph{specification}, and -#' an unset field takes that constructor's own default --- \code{0} for -#' each cutoff, \code{character(0)} for each \code{keep}, \code{TRUE} -#' for \code{keepIndel}. -#' \item to a pipeline it is an \emph{override}, and an unset field -#' leaves the dataset's construct-time value alone. -#' } -#' So \code{GenotypeFilterParam(mafCutoff = 0)} and -#' \code{GenotypeFilterParam()} differ: the first pins the cutoff at zero, -#' the second defers. \code{\link{PanelFilterParam}} needs no such -#' distinction and keeps ordinary defaults. +#' assembled, as one checked bundle: the genotype QC of a run of +#' \code{\link{fineMappingPipeline}}, \code{\link{twasWeightsPipeline}} +#' or \code{\link{colocboostPipeline}} on a \code{\link{QtlDataset}}. +#' A \code{QtlDataset} records no filter of its own; \code{keepSamples} +#' narrows it once at the start of the run, and the other fields apply to +#' each extracted block, against that block's samples. +#' @section Unset fields: +#' Every field defaults to \code{NULL}, meaning \strong{not set}: an unset +#' field is absent from the result rather than carried as \code{NULL}, and +#' takes its default when the run resolves the bundle --- \code{0} for +#' each cutoff, no restriction for each \code{keep}, \code{TRUE} for +#' \code{keepIndel}. So \code{GenotypeFilterParam()} filters nothing. #' @param mafCutoff Minor-allele-frequency floor. #' @param macCutoff Minor-allele-count floor; the stricter of this and #' \code{mafCutoff} applies. #' @param xvarCutoff Genotype-variance floor. -#' @param imissCutoff Per-variant missingness ceiling. +#' @param imissCutoff Per-sample missingness ceiling: a sample missing more +#' than this fraction of an extracted block's genotypes is dropped from +#' it. #' @param keepSamples Sample ids to restrict to; \code{character(0)} keeps #' all samples. #' @param keepVariants Variant ids to restrict to; \code{character(0)} keeps @@ -2523,6 +2420,182 @@ GenotypeFilterParam <- function( ) } +# Each cutoff a single finite non-negative number and keepIndel a flag, +# checked where the filter is built, so a bad value is reported against the +# argument that set it rather than surfacing inside an extraction. An unset +# field has nothing to check. +setValidity("GenotypeFilterParam", function(object) { + coll <- makeAssertCollection() + walk( + c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), + .gfpCheckCutoff, + object = object, + coll = coll + ) + if (!is.null(object@keepIndel)) { + assertFlag(object@keepIndel, .var.name = "keepIndel", add = coll) + } + problems <- coll$getMessages() + if (length(problems) == 0L) TRUE else problems +}) + +# @noRd +.gfpCheckCutoff <- function(nm, object, coll) { + value <- methods::slot(object, nm) + if (is.null(value)) { + return(invisible(NULL)) + } + assertNumber(value, lower = 0, finite = TRUE, .var.name = nm, add = coll) +} + +#' @rdname PhenotypeFilterParam +#' @aliases PhenotypeFilterParam-class +#' @exportClass PhenotypeFilterParam +setClass( + "PhenotypeFilterParam", + contains = "MethodParam", + slots = c( + naAction = "character_OR_NULL", + outlierAction = "character_OR_NULL", + outlierPvalThreshold = "numeric_OR_NULL", + outlierArgs = "MethodOptions_OR_NULL" + ) +) + +#' @title Phenotype Quality-Control Options +#' @description How a run of \code{\link{fineMappingPipeline}}, +#' \code{\link{twasWeightsPipeline}} or \code{\link{colocboostPipeline}} on +#' a \code{\link{QtlDataset}} treats the phenotypes it reads: missing +#' values, and multivariate outlier samples. The phenotype counterpart of +#' \code{\link{GenotypeFilterParam}}. A \code{QtlDataset}'s own accessors +#' (\code{\link{molecularTraits}}, \code{\link{residualizedPhenotypes}}) +#' apply none of it and return the data as stored. +#' @section Unset fields: +#' Every field defaults to \code{NULL}, meaning \strong{not set}, and takes +#' its default when the run resolves the bundle. \code{naAction} resolves +#' to the pipeline's own policy: fine-mapping and TWAS fits cannot take a +#' missing phenotype, so they drop the affected samples (and refuse +#' \code{"keep"}), while colocboost receives the phenotypes as they are. +#' Outliers are kept unless \code{outlierAction = "drop"}. +#' @param naAction How missing phenotype values are handled: \code{"drop"} +#' the samples with any missing value among the selected traits, +#' \code{"impute"} each trait's mean, or \code{"keep"} them as they are. +#' @param outlierAction \code{"keep"} or \code{"drop"} samples flagged as +#' multivariate outliers by a robust (MCD) Mahalanobis distance, computed +#' on the residualized phenotypes. +#' @param outlierPvalThreshold Two-sided p-value below which a sample is an +#' outlier. Default \code{1e-3} when unset. +#' @param outlierArgs A \code{\link{CovMcdOptions}} record of extra arguments +#' for \code{robustbase::covMcd()}, the outlier detector. +#' @return A \code{PhenotypeFilterParam} object, a \code{\link{MethodParam}}. +#' @seealso \code{\link{GenotypeFilterParam}} +#' @examples +#' PhenotypeFilterParam(naAction = "impute", outlierAction = "drop") +#' @importFrom checkmate assertChoice +#' @export +PhenotypeFilterParam <- function( + naAction = NULL, + outlierAction = NULL, + outlierPvalThreshold = NULL, + outlierArgs = NULL +) { + new( + "PhenotypeFilterParam", + naAction = naAction, + outlierAction = outlierAction, + outlierPvalThreshold = outlierPvalThreshold, + outlierArgs = outlierArgs + ) +} + +# Each set field one of its allowed values, checked where the bundle is +# built, so a bad value is reported against the argument that set it. An +# unset field has nothing to check. +setValidity("PhenotypeFilterParam", function(object) { + coll <- makeAssertCollection() + if (!is.null(object@naAction)) { + assertChoice( + object@naAction, + c("drop", "impute", "keep"), + .var.name = "naAction", + add = coll + ) + } + if (!is.null(object@outlierAction)) { + assertChoice( + object@outlierAction, + c("keep", "drop"), + .var.name = "outlierAction", + add = coll + ) + } + if (!is.null(object@outlierPvalThreshold)) { + assertNumber( + object@outlierPvalThreshold, + lower = 0, + upper = 1, + .var.name = "outlierPvalThreshold", + add = coll + ) + } + # Any MethodOptions fits the slot; only a covMcd record means anything to + # the outlier detector, which would otherwise fail on foreign arguments. + if (!is.null(object@outlierArgs)) { + engine <- metadata(object@outlierArgs)$engine + if (!identical(engine, "covMcd")) { + coll$push(glue( + "`outlierArgs` must be built with CovMcdOptions() (got a ", + "record for {engine %||% 'no engine'})." + )) + } + } + problems <- coll$getMessages() + if (length(problems) == 0L) TRUE else problems +}) + +# The run's phenotype QC with every unset field at its default, as a plain +# list the extraction reads. `naDefault` is the pipeline's NA policy and +# `naAllowed` what its fits can take; a choice outside it is refused here, +# naming the pipeline, rather than failing inside a fit. +# @noRd +.qtlResolvePhenotypeFilter <- function( + phenotypeFilterParam, + naDefault, + naAllowed, + caller +) { + .assertMethodParam(phenotypeFilterParam, "PhenotypeFilterParam") + naAction <- phenotypeFilterParam$naAction %||% naDefault + if (!is_in(naAction, naAllowed)) { + abort(glue( + "{caller}: naAction = \"{naAction}\" is not available here; its ", + "fits cannot take a missing phenotype. Use ", + "{str_flatten(str_c('\"', naAllowed, '\"'), ' or ')}." + )) + } + outlierArgs <- phenotypeFilterParam$outlierArgs %||% CovMcdOptions() + .assertMethodOptions(outlierArgs, "CovMcdOptions", "outlierArgs") + list( + naAction = naAction, + outlierAction = phenotypeFilterParam$outlierAction %||% "keep", + outlierPvalThreshold = phenotypeFilterParam$outlierPvalThreshold %||% + 1e-3, + outlierArgs = outlierArgs + ) +} + +# What an accessor applies: nothing. Missing values and outliers are kept, so +# molecularTraits() and residualizedPhenotypes() return the data as stored. +# @noRd +.qtlKeepAllPhenotypes <- function() { + list( + naAction = "keep", + outlierAction = "keep", + outlierPvalThreshold = 1e-3, + outlierArgs = CovMcdOptions() + ) +} + # ============================================================================= # Variant / sample filtering bundles # ----------------------------------------------------------------------------- @@ -2542,10 +2615,9 @@ GenotypeFilterParam <- function( # accept `removeIndels` where nothing reads it -- the failure mode these # constructors exist to prevent. # -# GenotypeFilterParam defaults every field to NULL ("not set") because its -# fields are a SPECIFICATION to QtlDataset and an OVERRIDE to the pipelines; -# absence is what distinguishes "pin this value" from "leave it alone". The -# other two have one meaning each and keep ordinary defaults. +# GenotypeFilterParam defaults every field to NULL ("not set"), resolved to +# its default by .qtlResolveFilter() when a run threads it to its +# extractions; the other two keep ordinary defaults. # # SumstatsCleaningParam sits with them because it runs on the same pass over # the same table, but it is coercion and normalisation (coerceNumeric, diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index d90de27e..482f2a08 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -1,11 +1,13 @@ # ============================================================================= # QtlFineMappingResult S4 class # ----------------------------------------------------------------------------- -# DFrame-subclass collection keyed by the identity tuple (study, context, -# trait, method). Each row holds a FineMappingRow payload. Class-level -# slots: -# * ldReference GenotypeHandle (NULL for individual-level fits, the -# LD-sketch handle for RSS-derived fits). +# RangedTupleList collection keyed by the identity tuple (study, context, +# trait, method). Each element is one fit's variants, with their topLoci +# values as its mcols; the fit and its cross-validation are columns of the +# collection's own mcols. Class-level slots: +# * ldReference the LD references RSS-derived fits used, each stored +# once; the ldReference mcols column names each row's (NA +# for an individual-level fit). # Optional columns jointStudies / jointContexts / jointTraits carry # semicolon-joined member identities for cross-axis joint fits emitted by # the joint dispatchers. @@ -16,14 +18,16 @@ NULL #' @title QTL Fine-Mapping Result Collection #' @description S4 collection of fine-mapping fits for one or more QTL -#' studies on a single LD block. Keyed by the identity tuple -#' \code{(study, context, trait, method)}; each entry is a -#' \code{FineMappingRow}. +#' studies, one row per \code{(study, context, trait, method)} fit. Each +#' element is a fit's variants: a \code{GRanges} on one chromosome whose +#' \code{mcols} hold the per-variant values \code{\link{topLoci}} reads. #' -#' Required columns: \code{study}, \code{context}, \code{trait}, -#' \code{method}, \code{entry}. The 4-tuple is unique. The caller is -#' expected to construct one \code{QtlFineMappingResult} per LD block (no -#' in-class block indexing). +#' Required \code{mcols()} columns: the identity tuple \code{study}, +#' \code{context}, \code{trait} and \code{method}, which is unique, and +#' each row's stored fit \code{susieFit} and cross-validation result +#' \code{cvResult}. The constructor also records \code{fitVariants}, the +#' variants each fit was made with. There is no LD-block axis: a trait's fit +#' is one row wherever its window falls. #' #' Optional columns \code{jointStudies}, \code{jointContexts}, #' \code{jointTraits} appear when the collection contains rows produced by a @@ -39,8 +43,8 @@ setClass( # ---- QtlFineMappingResult validity helpers --------------------------------- # Collect all contract violations (empty vector = valid). The per-entry checks -# run only once the required columns are present; the ldReference check always -# runs. +# run only once the required columns are present; FineMappingResultBase's own +# validity checks the LD references. # @noRd #' @importFrom checkmate makeAssertCollection assertNames checkNames .validateQtlFineMappingResult <- function(object) { @@ -61,7 +65,8 @@ setClass( coll$getMessages() } -# Entry-column + region/traitPos + joint-column + tuple-uniqueness contract. +# Payload-column + region/traitPos + joint-column + tuple-uniqueness +# contract. # @noRd .qfmrCheckEntries <- function(object) { jointCols <- intersect( @@ -113,9 +118,7 @@ setClass( # @noRd .qfmrCheckTupleUniqueness <- function(object, jointCols) { keyCols <- c("study", "context", "trait", "method", jointCols) - # Extract key columns directly rather than via `object[, keyCols]`: column- - # subsetting preserves the class while dropping the required `entry` column, - # and older S4Vectors revalidates that intermediate, spuriously failing. + # Read column by column: `[` takes no column index on a collection. keyTbl <- as_tibble(set_names( map(keyCols, .qfmrColOf, object = object), keyCols @@ -134,8 +137,6 @@ setClass( .tupleColumn(object, cn) } -# 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 # a recycling artefact deep inside the DataFrame assembly. @@ -150,18 +151,18 @@ setClass( return(invisible(NULL)) } abort(glue( - "`study`, `context`, `trait`, `method`, and `entry` must all ", + "`studyName`, `context`, `trait`, `method`, and `entry` must all ", "have the same length." )) } #' @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{ldReference} slot records the -#' LD reference used for RSS-derived fits; pass \code{NULL} (the default) for -#' individual-level fits. +#' @description Construct a \code{QtlFineMappingResult} collection from +#' per-tuple vectors and a list of \code{FineMappingRow} payloads (one per +#' tuple). The optional \code{ldReference} records the LD +#' reference each RSS-derived fit used; leave it \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. #' @param context Character vector of context labels (per tuple). Use @@ -182,9 +183,9 @@ setClass( #' "methylation"), recorded as a per-row provenance column. Length 1 or #' one per row; \code{NULL} (default) omits the column. #' @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{ldReference} cannot say which row came from which. +#' \code{"individual"} or \code{"sumstat"}. Where it is absent, the result +#' writers read a row's kind from its LD reference: a row with none saw +#' individual-level data. #' @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 @@ -192,9 +193,11 @@ 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 ldReference An optional genotype panel (see -#' \code{\link{readGenotypes}}) (the LD reference for RSS-derived fits), or -#' \code{NULL} for individual-level fits. +#' @param ldReference The LD reference RSS-derived fits were computed +#' against -- a genotype panel (see \code{\link{readGenotypes}}), a +#' \code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +#' a list with one per row; \code{NULL} for individual-level fits. Each +#' distinct reference is stored once. #' @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. @@ -203,11 +206,14 @@ setClass( #' 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. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{QtlFineMappingResult} object. #' @examples #' tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), #' pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) -#' fe <- fineMappingRow( +#' fe <- FineMappingRow( #' variantIds = tl$variant_id, susieFit = list(), topLoci = tl) #' QtlFineMappingResult(studyName = "s1", context = "brain", trait = "g1", #' method = "susie", entry = list(fe)) @@ -228,7 +234,8 @@ QtlFineMappingResult <- function( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) { .qfmrAssertArgs( studyName, @@ -240,10 +247,7 @@ QtlFineMappingResult <- function( jointContexts, jointTraits ) - n <- length(studyName) - .qfmrCheckTupleLengths(studyName, context, trait, method, entry) - payloads <- map(entry, .asFmRowPayload) - .checkRowPayloads(payloads, "FineMappingRow", "fine-mapping") + payloads <- .qfmrPayloads(entry) cols <- .qfmrMetadataCols( studyName, context, @@ -257,13 +261,43 @@ QtlFineMappingResult <- function( region, dataType, dataSource, - weightStandardized, - n + weightStandardized + ) + .withMetadata( + .rtlNewValidated("QtlFineMappingResult", payloads, cols, ldReference), + metadata ) - .rtlNewValidated("QtlFineMappingResult", payloads, cols, ldReference) } -# Every argument's type contract, checked before anything is built. +# The entries as fine-mapping row payloads, each on one chromosome. +# @noRd +.qfmrPayloads <- function(entry) { + payloads <- map(entry, .asFmRowPayload) + .checkRowPayloads(payloads, "FineMappingRow", "fine-mapping") + .qfmrRefuseMultiChromosome(payloads) + payloads +} + +# A QTL fit is one row per (study, context, trait, method), on one chromosome, +# so an entry whose variants span several -- a trans fit -- has no row to go +# in: split per chromosome, it would repeat its tuple and fail as a +# uniqueness violation. Said here, before the split, instead. +# @noRd +.qfmrRefuseMultiChromosome <- function(payloads) { + bad <- .multiChromosomeEntries(payloads) + if (length(bad) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "QtlFineMappingResult: `entry` element(s) ", + "{str_flatten(utils::head(bad, 5L), ', ')} span more than one ", + "chromosome. A row is one (study, context, trait, method) fit on one ", + "chromosome, so a fit across chromosomes has no row to go in." + )) +} + +# Every argument's type and length contract, checked before anything is +# built. # @noRd .qfmrAssertArgs <- function( studyName, @@ -289,6 +323,7 @@ QtlFineMappingResult <- function( assertCharacter(jointStudies, null.ok = TRUE) assertCharacter(jointContexts, null.ok = TRUE) assertCharacter(jointTraits, null.ok = TRUE) + .qfmrCheckTupleLengths(studyName, context, trait, method, entry) } # The collection's outer mcols: the identity tuple, each entry's fit / cv @@ -307,16 +342,17 @@ QtlFineMappingResult <- function( region, dataType, dataSource, - weightStandardized, - n + weightStandardized ) { + n <- length(studyName) baseCols <- list( study = as.character(studyName), context = as.character(context), trait = as.character(trait), method = as.character(method), susieFit = S4Vectors::SimpleList(map(payloads, susieFit)), - cvResult = S4Vectors::SimpleList(map(payloads, cvResult)) + cvResult = S4Vectors::SimpleList(map(payloads, cvResult)), + fitVariants = IRanges::CharacterList(map(payloads, .fmRowFitVariants)) ) withJoint <- .qfmrAppendJointCols( baseCols, @@ -384,11 +420,33 @@ QtlFineMappingResult <- function( setMethod( "fineMappingResult", "QtlFineMappingResult", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + blockId = NULL + ) { + .qfmrRefuseBlockId(blockId, "fineMappingResult(QtlFineMappingResult)") x[.qfmrSelectRowIndex(x, studyName, context, trait, method)] } ) +# A QTL fit is one row, named by (study, context, trait, method), so there is +# no block for `blockId` to pick; one is refused rather than ignored. NA +# counts as unset, as it does for the GWAS-side refusal of context / trait. +# @noRd +.qfmrRefuseBlockId <- function(blockId, caller) { + if (is.null(blockId) || (length(blockId) == 1L && is.na(blockId))) { + return(invisible(NULL)) + } + abort(glue( + "{caller}: `blockId` names an LD block of a GWAS fit. A QTL fit is ", + "one row; select it with `studyName`, `context`, `trait` and `method`." + )) +} + # Derived collection-level accessors (delegate to entry-level methods). #' @rdname pip @@ -401,23 +459,10 @@ setMethod( studyName = NULL, context = NULL, trait = NULL, - method = NULL, - returnList = FALSE + method = NULL ) { - pip <- .fmrRowPip( - .fmrRowParts( - x, - .qfmrSelectRowIndex(x, studyName, context, trait, method) - ) - ) - if (isTRUE(returnList)) { - nm <- glue( - "{as.character(x$study)[1L]}|{as.character(x$context)[1L]}|", - "{as.character(x$trait)[1L]}|{as.character(x$method)[1L]}" - ) - return(set_names(list(pip), nm)) - } - pip + idx <- .qfmrSelectRowIndex(x, studyName, context, trait, method) + .fmrRowPip(.fmrRowParts(x, idx)) } ) @@ -433,17 +478,17 @@ setMethod( context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { # The shared FineMappingResultBase accessors pass the whole selector - # set, and only GwasFineMappingResult is region-indexed. Refusing a - # non-NULL `region` is the point of naming it: it used to vanish into - # `...` and silently return the study/context/trait/method match. - if (!is.null(region)) { + # set, and only GwasFineMappingResult is block-indexed. Refusing a + # non-NULL `blockId` is the point of naming it: a selector absorbed + # by `...` would silently return the study/context/trait/method match. + if (!is.null(blockId)) { abort(glue( - "QtlFineMappingResult is not region-indexed: select with ", - "study / context / trait / method. `region` applies to ", - "GwasFineMappingResult only." + "QtlFineMappingResult has no LD blocks: select with ", + "study / context / trait / method. `blockId` ", + "applies to GwasFineMappingResult only." )) } .fmrRowParts( @@ -465,10 +510,11 @@ setMethod( trait = NULL, method = NULL ) { - cvResult(.fmrRowParts( + parts <- .fmrRowParts( x, .qfmrSelectRowIndex(x, studyName, context, trait, method) - )) + ) + cvResult(.fitCoverageChecked(parts, "cvResult()")) } ) @@ -499,10 +545,9 @@ setMethod("show", "QtlFineMappingResult", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldReference)) { + ldSrc <- .ldRefsLabel( + ldReference(object), "NULL (individual-level fit)" - } else { - .ldRefLabel(object@ldReference) - } + ) cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 83b46fc1..c9250442 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -15,7 +15,7 @@ # `[[` 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 (ldReference, genome, qcInfo). +# Slots hold COLLECTION-LEVEL scalars only (ldReference, genome, qcOptions). # 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. @@ -31,14 +31,23 @@ NULL #' \code{nrow()} counts elements, \code{ncol()} counts metadata columns and #' \code{colnames()} names them, so the collections read exactly as the #' \code{DFrame}-shaped ones they replace. \code{$} and \code{$<-} -#' read and write \code{mcols} columns. \code{[} selects elements and +#' read and write \code{mcols} columns. Storing metadata, whether by +#' \code{$<-}, \code{mcols<-} or its older spellings \code{values<-} and +#' \code{elementMetadata<-}, refuses an identity column (\code{study}, +#' \code{context}, \code{trait}, \code{method}, their \code{gwas} +#' counterparts and \code{blockId}) that is not character; \code{NA} values +#' are allowed. \code{[} selects elements and #' \strong{rejects} a second argument, because the stock method would #' silently discard it. \code{endoapply()} maps over the elements and -#' rebuilds the object with its collection-level slots intact. +#' rebuilds the object with its collection-level slots intact; +#' \code{sort()}, \code{unique()} and \code{trim()} work on each element +#' the same way, so they too return the collection's own class rather than +#' a bare \code{GRangesList}. #' @param x,X A \code{RangedTupleList} collection. #' @param name An \code{mcols} column name. #' @param do.NULL,prefix Unused; present for generic compatibility. -#' @param value Replacement value for that column. +#' @param value For \code{$<-}, the replacement column; for +#' \code{elementMetadata<-}, the replacement metadata table. #' @param i Element selector. #' @param j Not supported; supplying it is an error. #' @param drop Passed through to the inherited method. @@ -46,11 +55,15 @@ NULL #' @param FUN A function applied to each element, returning a \code{GRanges}. #' @param objects Further collections to append, as \code{c()} and #' \code{append()} pass them. -#' @param use.names,ignore.mcols,check Unused; present for generic -#' compatibility. +#' @param use.names For \code{trim()}, passed to each element's +#' \code{trim()}; otherwise unused, present for generic compatibility. +#' @param ignore.mcols,check Unused; present for generic compatibility. +#' @param decreasing Passed to each element's \code{sort()}. +#' @param incomparables Passed to each element's \code{unique()}. #' @return \code{nrow()} and \code{ncol()} integers; \code{colnames()} a -#' character vector; \code{$} a metadata column; \code{$<-}, \code{[} and -#' \code{endoapply()} a collection of the same class. +#' character vector; \code{$} a metadata column; \code{$<-}, +#' \code{elementMetadata<-}, \code{[}, \code{endoapply()}, \code{sort()}, +#' \code{unique()} and \code{trim()} a collection of the same class. #' @examples #' data(qtlSumStatsMulticontextExample) #' mc <- qtlSumStatsMulticontextExample @@ -79,6 +92,20 @@ NULL #' elements and \code{mcols} together, but leaves slots untouched, so a #' per-element slot silently ends up the wrong length and positionally wrong. #' +#' @section Sequence names and genome build: Every range pecotmr holds is on +#' UCSC sequence names (\code{chr1}, \code{chrX}, \code{chrM}), the style +#' \code{seqlevelsStyle(x) <- "UCSC"} gives. Ranges read from a file, +#' placed by variant id, passed to a constructor or given as a range +#' argument are renamed on the way in (\code{"1"} and \code{"chr1"} both +#' become \code{chr1}), so ranges from different inputs compare as they +#' are. A query handed straight to an inherited Bioconductor method, such +#' as \code{subsetByOverlaps()}, is not renamed: give it in UCSC style. +#' A pipeline's result carries the genome build its inputs name in +#' \code{seqinfo()}, as do the ranged views of it (\code{topLoci()}, +#' \code{colocVariants()}, ...); inputs naming different builds are +#' refused. When no input names one, \code{genome()} is \code{NA} until it +#' is set with \code{genome(x) <- "hg38"}. +#' #' @section Invariant: One seqname and one strand per element. \code{range()} #' splits on both, so a mixed element would return two ranges and break the #' 1:1 element-to-span mapping the rest of the package relies on. Variants @@ -87,9 +114,70 @@ NULL setClass("RangedTupleList", contains = c("VIRTUAL", "CompressedGRangesList")) methods::setValidity("RangedTupleList", function(object) { - .rtlCheckSingleSpan(object) + span <- .rtlCheckSingleSpan(object) + problems <- c( + if (!isTRUE(span)) span, + .rtlIdentityProblems(mcols(object, use.names = FALSE)) + ) + if (length(problems) == 0L) TRUE else problems +}) + +# The identity columns of the metadata `md` name a row, so each is character. +# NA stays allowed: a GWAS side has no context or trait, and a row off the +# LD-block axis has no blockId. +# @noRd +.rtlIdentityProblems <- function(md) { + cols <- intersect( + c( + "study", + "context", + "trait", + "method", + "gwasStudy", + "gwasContext", + "gwasTrait", + "gwasMethod", + "blockId" + ), + colnames(md) + ) + list_c(map(cols, .rtlIdentityProblem, md = md), ptype = character()) +} + +# @noRd +.rtlIdentityProblem <- function(cn, md) { + v <- md[[cn]] + if (is.character(v)) { + return(character(0)) + } + as.character(glue( + "the `{cn}` column must be character (got {class(v)[[1L]]})." + )) +} + +#' @rdname genomicRegion +#' @examples +#' data(qtlFineMappingExample) +#' genomicRegion(qtlFineMappingExample) +#' data(gwasSumStatsS4Example) +#' genomicRegion(gwasSumStatsS4Example) +#' @export +setMethod("genomicRegion", "RangedTupleList", function(x) { + .getRegionColumn(x) }) +# `obj` carrying the caller's `metadata`: a free-form list, as metadata() +# is on any Bioconductor vector. +# @noRd +#' @importFrom checkmate assertList +.withMetadata <- function(obj, metadata) { + assertList(metadata, .var.name = "metadata") + if (length(metadata) == 0L) { + return(obj) + } + S4Vectors::`metadata<-`(obj, value = metadata) +} + # Each element must occupy exactly one (seqname, strand) span. range() already # splits on both, so an element that yields more than one range has violated # the invariant -- no need to inspect seqnames and strand separately. @@ -152,6 +240,76 @@ methods::setValidity("RangedTupleList", function(object) { ) } +# ----------------------------------------------------------------------------- +# Element names +# ----------------------------------------------------------------------------- + +# The identity columns an element's name is read from, in reading order. A +# name is the present columns' values joined by "|", missing parts skipped, so +# it reads as the row's key: "Q1|brain|ENSG1|susie". +# @noRd +.RTL_NAME_COLUMNS <- c( + "study", + "context", + "trait", + "method", + "gwasStudy", + "gwasContext", + "gwasTrait", + "gwasMethod", + "analysis", + "cosId", + "blockId", + "qtlCs", + "gwasCs", + "jointStudies", + "jointContexts", + "jointTraits" +) + +# Element names from the identity columns, as Bioconductor keys a List's +# elements. Rows sharing an identity -- one tuple split across chromosomes -- +# are told apart by their span, the key the uniqueness checks already use. +# NULL when the collection carries no identity columns. +# @noRd +.rtlElementNames <- function(grl) { + md <- mcols(grl, use.names = FALSE) + cols <- intersect(.RTL_NAME_COLUMNS, colnames(md)) + if (length(cols) == 0L || length(grl) == 0L) { + return(NULL) + } + parts <- exec(cbind, !!!map(cols, .rtlNameColumn, md = md)) + keys <- apply(parts, 1L, .rtlJoinNameParts) + shared <- is_in(keys, keys[duplicated(keys)]) + if (!any(shared)) { + return(keys) + } + spans <- .rtlRangeKeys(grl) + spans <- if_else(is.na(spans), str_c("row", seq_along(keys)), spans) + if_else(shared, str_c(keys, spans, sep = "|"), keys) +} + +# @noRd +.rtlNameColumn <- function(nm, md) { + as.character(md[[nm]]) +} + +# @noRd +.rtlJoinNameParts <- function(parts) { + str_flatten(parts[!is.na(parts) & nzchar(parts)], "|") +} + +# `grl` with its element names set from its identity columns, left as it is +# when it carries none. +# @noRd +.rtlNamed <- function(grl) { + nms <- .rtlElementNames(grl) + if (is.null(nms)) { + return(grl) + } + `names<-`(grl, nms) +} + # Rebuild `x` from a new list of GRanges elements, carrying every # collection-level slot over and narrowing mcols by `keep`. # @@ -165,7 +323,7 @@ methods::setValidity("RangedTupleList", function(object) { # during initialize(), and a subclass's validity method reads its identity # columns and slots. Building the object bare and filling it in afterwards # trips that check on the way past. - bare <- GenomicRanges::GRangesList(elements) + bare <- .rtlBindElements(elements) # seqinfo is collection-level state, exactly like the slots below: it # carries the genome build. A rebuild from bare elements starts with the # seqlevels those elements happen to span -- none at all when everything @@ -178,6 +336,13 @@ methods::setValidity("RangedTupleList", function(object) { } else { S4Vectors::`mcols<-`(withSeqinfo, value = md[keep, , drop = FALSE]) } + # The rebuilt elements keep the names they had -- the caller may have set + # their own -- and an unnamed collection is named off its identity. + grl <- if (is.null(names(x))) { + .rtlNamed(grl) + } else { + `names<-`(grl, names(x)[keep]) + } ownSlots <- .rtlOwnSlots(x) slotArgs <- set_names(map(ownSlots, .rtlGetSlot, x = x), ownSlots) exec(methods::new, class(x), grl, !!!slotArgs) @@ -270,8 +435,28 @@ setMethod("$", "RangedTupleList", function(x, name) { #' @rdname RangedTupleList-methods #' @export setMethod("$<-", "RangedTupleList", function(x, name, value) { + derived <- is.null(names(x)) || identical(names(x), .rtlElementNames(x)) md <- `[[<-`(mcols(x, use.names = FALSE), name, value = value) - S4Vectors::`mcols<-`(x, value = md) + out <- S4Vectors::`mcols<-`(x, value = md) + # Names read off the identity follow an edit to it; names the caller set + # are the caller's to keep. + if (derived) .rtlNamed(out) else out +}) + +# mcols<- and values<- both store their table through this generic, so one +# method checks all three spellings. The inherited method stores the table +# without running validity, which would keep an identity column of the wrong +# type. +#' @rdname RangedTupleList-methods +#' @importFrom S4Vectors elementMetadata<- +#' @export +setMethod("elementMetadata<-", "RangedTupleList", function(x, ..., value) { + out <- methods::callNextMethod() + problems <- .rtlIdentityProblems(mcols(out, use.names = FALSE)) + if (length(problems) > 0L) { + abort(problems) + } + out }) #' @rdname RangedTupleList-methods @@ -372,44 +557,216 @@ setMethod("endoapply", "RangedTupleList", function(X, FUN, ...) { .rtlRebuild(X, elements, seq_along(X)) }) +# The inherited GRangesList sort() / unique() / trim() work per element too, +# but rebuild the result as a bare CompressedGRangesList, dropping the class +# and every collection-level slot. Routed through endoapply() they keep both. +#' @rdname RangedTupleList-methods +#' @importFrom BiocGenerics sort +#' @export +setMethod("sort", "RangedTupleList", function(x, decreasing = FALSE, ...) { + endoapply(x, sort, decreasing = decreasing, ...) +}) + +#' @rdname RangedTupleList-methods +#' @importFrom BiocGenerics unique +#' @export +setMethod( + "unique", + "RangedTupleList", + function(x, incomparables = FALSE, ...) { + endoapply(x, unique, incomparables = incomparables, ...) + } +) + +#' @rdname RangedTupleList-methods +#' @importFrom IRanges trim +#' @export +setMethod("trim", "RangedTupleList", function(x, use.names = TRUE, ...) { + endoapply(x, trim, use.names = use.names, ...) +}) + # A stable per-element key for the element's own genomic span, used where an # identity tuple needs a positional component. Derived from range() rather than # from a stored label so it cannot drift out of step with the variants, and so -# it stays correct after subsetRegion() narrows an element. +# it stays correct after an element is narrowed. The keys are values, so they +# do not carry the collection's element names. An empty element has no span +# and keys NA. # @noRd .rtlRangeKeys <- function(x) { if (length(x) == 0L) { return(character(0)) } + spans <- .rtlFirstSpans(x) + keys <- rep(NA_character_, length(x)) + keys[spans$has] <- .rtlSpanKey(spans$first) + keys +} + +# Each element's span -- its first range under range(), which every element +# of a collection has exactly one of (.rtlCheckSingleSpan()) -- in element +# order, and which elements have one. One range() over the whole list: one +# per element made building the keys cost a millisecond a row. +# @noRd +.rtlFirstSpans <- function(x) { spans <- range(x) - map_chr(as.list(spans), .rtlOneRangeKey) + n <- lengths(spans) + has <- n > 0L + flat <- unlist(spans, use.names = FALSE) + list(first = flat[(cumsum(n) - n + 1L)[has]], has = has) } +# The key of the first range of `g`, a span: callers pass range() of a +# GRanges that has variants (an empty GWAS entry is skipped before it is +# keyed). # @noRd .rtlOneRangeKey <- function(g) { - if (length(g) == 0L) { - return(NA_character_) - } - str_c( - as.character(seqnames(g))[[1L]], - start(g)[[1L]], - end(g)[[1L]], - sep = "_" - ) + .rtlSpanKey(g[1L]) +} + +# "chrom_start_end" for each range of `gr`: the one formatter every span key +# goes through, so a key minted for one range and the keys of a collection +# agree by construction. +# @noRd +.rtlSpanKey <- function(gr) { + str_c(as.character(seqnames(gr)), start(gr), end(gr), sep = "_") +} + +# The seqname each element of a GRangesList sits on, NA for an empty one, as +# .rtlElementSeqname() reads one element -- read off the joined elements +# rather than element by element. +# @noRd +.rtlElementSeqnames <- function(x) { + n <- lengths(x) + has <- n > 0L + flat <- unlist(x, use.names = FALSE) + out <- rep(NA_character_, length(x)) + out[has] <- as.character(seqnames(flat))[(cumsum(n) - n + 1L)[has]] + out +} + +# Whether the elements' variant metadata has column `cn`. A collection's +# elements share one variant metadata table, so all of them have it or none +# does. +# @noRd +.rtlHasVariantColumn <- function(x, cn) { + md <- mcols(unlist(x, use.names = FALSE), use.names = FALSE) + is_in(cn, colnames(md)) } # ----------------------------------------------------------------------------- -# subsetRegion +# updateObject # ----------------------------------------------------------------------------- -#' @rdname subsetRegion +#' @title Update an Object Saved by an Earlier pecotmr +#' @description Bring an object saved by an earlier version of pecotmr up to +#' date. An up-to-date object is returned unchanged; an older one gets every +#' update below that applies to it, in the one call. +#' +#' \itemize{ +#' \item Collections keep their LD references per row: each distinct +#' reference once in the \code{ldReference} slot, and an +#' \code{ldReference} column naming the one every row uses (in +#' \code{outcomeInfo} for a \code{ColocBoostResult}). An object saved +#' when it held a single reference for all its rows is converted by +#' keying every row to that reference (for a \code{ColocBoostResult}, +#' every summary-statistic outcome), and one that held none by marking +#' every row LD-free. An object saved when the slot was named +#' \code{ldSketch} has it renamed first. +#' \item A genotype panel saved before panels recorded where their +#' genotypes come from (an LD reference, or a \code{QtlDataset}'s +#' genotypes) is read again from its files, as +#' \code{\link{readGenotypes}} reads them, and cut to the variants and +#' samples it held: a VCF, GDS or PLINK1 panel then reads through its +#' format's own backend, and a stochastic sketch records its real +#' sample count and allele frequencies. Only the files' variant and +#' sample lists, and a sketch's \code{.afreq}, are read; no genotypes +#' are, and nothing is written. An LD reference whose files cannot be +#' read again is kept as saved, with a warning, and updating again once +#' they are back finishes the job; a \code{QtlDataset} whose genotypes +#' cannot be is an error. +#' \item Collections name their elements by their identity tuple; one +#' saved without names gets them. +#' \item Summary statistics keep their QC settings in \code{qcOptions} +#' and each row's QC audit in a \code{qcAudit} column; ones saved with +#' both in one \code{qcInfo} record have it split between the two. +#' Their genome build is in \code{seqinfo()}; ones saved with it in a +#' \code{genome} slot have it moved there. +#' \item Fine-mapping results and TWAS weights record the variants each +#' row was fitted on in a \code{fitVariants} column; ones saved without +#' it have it filled in from their fits. +#' \item A \code{CtwasResult} holds one element per region; one saved as a +#' table of whole runs is rebuilt. +#' \item A \code{QtlDataset} no longer stores run settings (genotype +#' QC cutoffs, \code{scaleResiduals}); one saved with them has them +#' dropped, as the pipelines' \code{\link{GenotypeFilterParam}} and +#' \code{\link{ResidualizationParam}} now carry them. One saved with +#' its study in a \code{study} slot has it moved to \code{studyName}. +#' \item A \code{MultiStudyQtlDataset} is now a list of its studies; one +#' saved when it held them in a slot is rebuilt as one, its studies +#' updated too. +#' \item An \code{LdScore} or \code{LdEigen} saved before it could keep +#' an LD reference stores its blocks' LD itself, and gets none; one +#' saved with the reference's sample size as \code{nRef} has it moved +#' to \code{nSamples}. +#' \item An \code{H2Estimate} saved with its estimates under the slots' +#' earlier names (\code{h2}, \code{h2Se}, \code{local}, +#' \code{tauBlocks}) has them moved to the current ones. +#' } +#' @param object A collection (summary statistics, fine-mapping results, TWAS +#' weights, a colocalization or cTWAS result), a \code{QtlDataset}, a +#' \code{MultiStudyQtlDataset}, an \code{LdScore} or \code{LdEigen}, or an +#' \code{H2Estimate}. +#' @param ... Passed on to the inherited method. +#' @param verbose Report the update. +#' @return \code{object} in the current representation. +#' @examples +#' data(qtlSumStatsExample) +#' # An object built by this version needs nothing. +#' identical(updateObject(qtlSumStatsExample), qtlSumStatsExample) +#' @name updateObject-methods +#' @rdname updateObject-methods +NULL + +#' @rdname updateObject-methods +#' @importFrom BiocGenerics updateObject #' @export -setMethod("subsetRegion", "RangedTupleList", function(x, region) { - win <- .asGRegion(region) - elements <- map(as.list(x), .rtlRestrictOne, win = win) - keep <- lengths(elements) > 0L - .rtlRebuild(x, elements[keep], keep) -}) +setMethod( + "updateObject", + "RangedTupleList", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = '", class(object)[[1L]], "')") + } + methods::callNextMethod( + .rtlNamed(.updateRowLdRefs(object)), + ..., + verbose = verbose + ) + } +) + +# `object` with each slot an earlier version saved under another name moved +# to its current one: `renames` maps each old name to the new. The inherited +# update keeps only the slots a class still has, so a value left under its +# old name would be dropped. A name the object was not saved under is +# skipped. +# @noRd +#' @importFrom purrr reduce2 +.renameSavedSlots <- function(object, renames) { + reduce2(names(renames), unname(renames), .renameSavedSlot, .init = object) +} + +# slot() rather than attr(): R stores a NULL slot as a placeholder symbol, +# which slot() reads back as NULL and attr() hands back unconverted. +# @noRd +.renameSavedSlot <- function(object, from, to) { + if (is.null(attr(object, from, exact = TRUE))) { + return(object) + } + value <- methods::slot(object, from) + attr(object, from) <- NULL + `slot<-`(object, to, check = FALSE, value = value) +} # ----------------------------------------------------------------------------- # Construction helper: enforce one seqname per element @@ -426,23 +783,205 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { split <- .rtlSplitBySeqname(map(payloads, variants)) md <- exec(S4Vectors::DataFrame, !!!c(cols, list(check.names = FALSE))) S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(split$entry), + .rtlBindElements(split$entry), value = md[split$fromIdx, , drop = FALSE] ) } -# Build and validate a RangedTupleList subclass from its payloads and metadata -# columns -- the shared tail of the TwasWeights and QtlFineMappingResult -# constructors. +# Build a RangedTupleList subclass from its payloads and metadata columns -- +# the shared tail of the TwasWeights and QtlFineMappingResult constructors. +# new() validates it, once. `ldReference` is one reference for every payload +# or a list with one per payload; each distinct one is stored once, and every +# row names its own in the `ldReference` column. # @noRd .rtlNewValidated <- function(Class, payloads, cols, ldReference) { - obj <- new( + dict <- .ldRefDict(.ldRefPerTuple(ldReference, length(payloads))) + new( Class, - .rtlGrlWithMetadata(payloads, cols), - ldReference = .asLdRef(ldReference) + .rtlNamed(.rtlGrlWithMetadata( + payloads, + c(cols, list(ldReference = dict$keys)) + )), + ldReference = dict$refs + ) +} + +# ----------------------------------------------------------------------------- +# Joining elements into a list +# ----------------------------------------------------------------------------- + +# GenomicRanges::GRangesList(elements), built faster. GRangesList() joins +# the elements' variant metadata through S4Vectors, which reads every column +# of every element by S4 dispatch, about 0.25 ms a cell: 3 s for a 1,000-row +# collection of fine-mapping fits. When every element is a plain GRanges +# whose metadata holds the same plain vector columns, in the same order and +# of the same types -- what the collection constructors pass -- they are +# joined from their vectors instead, giving the identical object. Anything +# else takes GRangesList(). Like GRangesList(), which builds its result inside +# suppressWarnings(), the join reports no warnings: merging the elements' +# seqinfo warns about every two on different chromosomes. +# @noRd +.rtlBindElements <- function(elements) { + flat <- suppressWarnings(.rtlJoinPlainElements(elements)) + if (is.null(flat)) { + return(GenomicRanges::GRangesList(elements)) + } + IRanges::relist( + flat, + IRanges::PartitioningByEnd( + cumsum(lengths(elements)), + names = names(elements) + ) + ) +} + +# The elements of collections `parts`, in order, as one GRangesList: what +# GRangesList() makes of their elements, keeping their names. Each part is +# joined whole -- its elements are already one GRanges underneath -- rather +# than taken apart with as.list() and put back together, which cost about +# 0.6 ms an element. c() joins the parts' variant metadata as GRangesList() +# would, filling a column one part lacks with NA, and its warnings are +# silenced as GRangesList() silences them (.rtlBindElements()). +# @noRd +.rtlJoinParts <- function(parts) { + flats <- unname(map(parts, unlist, use.names = FALSE)) + flat <- suppressWarnings(exec(c, !!!flats)) + ends <- cumsum(list_c(map(parts, .rtlElementLengths), ptype = integer())) + IRanges::relist( + flat, + IRanges::PartitioningByEnd(ends, names = .rtlJoinedNames(parts)) + ) +} + +# @noRd +.rtlElementLengths <- function(x) { + unname(lengths(x)) +} + +# The elements joined into one GRanges as c() joins them, or NULL when one of +# them falls outside the plain case .rtlBindElements() builds. +# @noRd +.rtlJoinPlainElements <- function(elements) { + elements <- unname(as.list(elements)) + if ( + length(elements) == 0L || + !all(map_lgl(elements, .rtlIsPlainGRanges)) + ) { + return(NULL) + } + columns <- map(elements, .rtlMcolList) + if (!.rtlSameVectorColumns(columns)) { + return(NULL) + } + flat <- GenomicRanges::GRanges( + seqnames = list_c( + map(elements, .rtlSeqnameValues), + ptype = character() + ), + ranges = IRanges::IRanges( + start = list_c(map(elements, start), ptype = integer()), + end = list_c(map(elements, end), ptype = integer()), + names = .rtlJoinedNames(elements) + ), + strand = list_c(map(elements, .rtlStrandValues), ptype = character()), + seqinfo = .rtlMergedSeqinfo(elements) ) - validObject(obj) - obj + .rtlWithJoinedMcols(flat, columns) +} + +# A GRanges itself, not a subclass, with no metadata() of its own, which c() +# would carry over from the first element. +# @noRd +.rtlIsPlainGRanges <- function(g) { + methods::is(g, "GRanges") && + identical(class(g)[[1L]], "GRanges") && + length(S4Vectors::metadata(g)) == 0L +} + +# One element's variant metadata as a plain list of its columns. +# @noRd +.rtlMcolList <- function(g) { + as.list(mcols(g, use.names = FALSE)) +} + +# TRUE when every element's metadata holds the first one's plain vector +# columns: the same names, in the same order, of the same types. +# @noRd +.rtlSameVectorColumns <- function(columns) { + first <- columns[[1L]] + all(map_lgl( + columns, + .rtlColumnsMatch, + names = names(first) %||% character(0), + types = map_chr(first, typeof) + )) +} + +# @noRd +.rtlColumnsMatch <- function(cols, names, types) { + identical(names(cols) %||% character(0), names) && + identical(map_chr(cols, typeof), types) && + all(map_lgl(cols, .rtlIsPlainVector)) +} + +# An atomic vector with no attributes beyond its names -- no dimensions or +# class -- so joining it is plain concatenation, names included. +# @noRd +.rtlIsPlainVector <- function(v) { + is.atomic(v) && all(is_in(names(attributes(v)), "names")) +} + +# @noRd +.rtlSeqnameValues <- function(g) { + as.character(seqnames(g)) +} + +# @noRd +.rtlStrandValues <- function(g) { + as.character(GenomicRanges::strand(g)) +} + +# The elements' variant names joined, "" for an element without any; NULL +# when none has any, as c() leaves them. +# @noRd +.rtlJoinedNames <- function(elements) { + nms <- map(elements, names) + if (all(map_lgl(nms, is.null))) { + return(NULL) + } + list_c(map2(nms, elements, .rtlNamesOrBlank), ptype = character()) +} + +# @noRd +.rtlNamesOrBlank <- function(nm, g) { + nm %||% rep("", length(g)) +} + +# The elements' seqinfo merged as c() merges it, each distinct one once, in +# the order they appear. +# @noRd +.rtlMergedSeqinfo <- function(elements) { + infos <- unique(map(elements, GenomeInfoDb::seqinfo)) + reduce(infos, S4Vectors::merge) +} + +# `flat` carrying the elements' metadata columns, each joined once. +# @noRd +.rtlWithJoinedMcols <- function(flat, columns) { + cn <- names(columns[[1L]]) %||% character(0) + if (length(cn) == 0L) { + return(flat) + } + joined <- set_names(map(cn, .rtlJoinColumn, columns = columns), cn) + S4Vectors::`mcols<-`( + flat, + value = S4Vectors::DataFrame(joined, check.names = FALSE) + ) +} + +# @noRd +.rtlJoinColumn <- function(cn, columns) { + list_c(map(columns, cn)) } # Split any multi-seqname element into one element per seqname, and report the @@ -500,17 +1039,18 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { g[chroms == level] } -# Split each element by an LD-block manifest instead of by seqname, returning -# the same (entry, fromIdx) shape plus the block key each piece belongs to. +# Split each element across a set of windows (a GWAS `region`, typically LD +# blocks) instead of by seqname, returning the same (entry, fromIdx) shape +# plus the key and the interval of the window each piece belongs to. # # A genome-wide GWAS split by seqname gives one element per chromosome, which # is too coarse for cTWAS: its EM needs per-block context (§4.7). `blocks` is a -# GRanges of LD blocks whose names supply the keys. +# GRanges of windows whose names supply the keys. # -# A variant matching no block is dropped rather than pooled into a catch-all: -# a variant outside every LD block has no block-local LD to be fine-mapped -# against, so carrying it would put variants in a block whose LD does not -# describe them. The count is reported so the loss is never silent. +# A variant matching no window is dropped rather than pooled into a +# catch-all: the windows are what the caller asked to analyse, and a variant +# outside every LD block has no block-local LD to be fine-mapped against. The +# count is reported so the loss is never silent. # @noRd .rtlSplitByBlocks <- function(entry, blocks) { entry <- as.list(entry) @@ -518,7 +1058,8 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { return(list( entry = list(), fromIdx = integer(0), - blockId = character(0) + blockId = character(0), + blockRange = GenomicRanges::GRanges() )) } notRanges <- !map_lgl(entry, methods::is, "GRanges") @@ -534,12 +1075,12 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { dropped <- sum(lengths(entry)) - sum(map_int(pieces, .rtlPieceSize)) if (dropped > 0L) { msg <- glue( - "{dropped} variant(s) overlap no LD block and were dropped; ", - "a variant outside every block has no block-local LD to be ", - "fine-mapped against." + "{dropped} variant(s) lie outside every `region` window and ", + "were dropped." ) warn(msg) } + keys <- unname(list_c(map(pieces, names), ptype = character())) list( # unname(): the flattened names were an artifact of base unlist()'s # `outer.inner` mangling and were never coherent -- a multi-seqname @@ -548,29 +1089,30 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { # already had to unname() derived values to keep them out of mcols. entry = unname(list_flatten(pieces)), fromIdx = rep(seq_along(entry), lengths(pieces)), - blockId = unname(list_c(map(pieces, names))) + blockId = keys, + blockRange = unname(blocks[keys]) ) } -# The manifest must name its blocks: the names become `blockId`, which is what +# Every window needs a name: the names become `blockId`, which is what # downstream code keys regions by. # @noRd .rtlValidateBlocks <- function(blocks) { if (!methods::is(blocks, "GRanges")) { msg <- glue( - "`ldBlocks` must be a GRanges of LD blocks ", + "`region` must be a GRanges of windows ", "(got {class(blocks)[[1L]]})." ) abort(msg) } if (length(blocks) == 0L) { - abort("`ldBlocks` is empty; it must describe at least one LD block.") + abort("`region` is empty; it must describe at least one window.") } keys <- .rtlBlockKeys(blocks) if (anyDuplicated(keys) > 0L) { dup <- unique(keys[duplicated(keys)]) msg <- glue( - "`ldBlocks` keys must be unique; repeated: ", + "`region` window names must be unique; repeated: ", "{str_flatten(head(dup, 5L), ', ')}." ) abort(msg) @@ -605,7 +1147,11 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { # One element -> a named list of per-block GRanges, in manifest order. # @noRd .rtlSplitOneByBlocks <- function(g, blocks) { - hits <- IRanges::findOverlaps(g, blocks, select = "first") + hits <- IRanges::findOverlaps( + .locusRanges(g), + .locusRanges(blocks), + select = "first" + ) if (!any(!is.na(hits))) { return(list()) } @@ -627,24 +1173,6 @@ setMethod("subsetRegion", "RangedTupleList", function(x, region) { g[!is.na(hits) & hits == i] } -# Keep only the variants of one element that overlap the window. -# -# The seqname is checked first because an element on another chromosome cannot -# overlap by definition, and going straight to overlapsAny() would emit -# GenomicRanges' "no sequence levels in common" warning for every such element -# on every call -- pure noise for a collection spanning several chromosomes. -# @noRd -.rtlRestrictOne <- function(g, win) { - onWindowChrom <- is_in( - as.character(seqnames(g)), - as.character(seqnames(win)) - ) - if (!any(onWindowChrom)) { - return(g[0L]) - } - g[onWindowChrom & IRanges::overlapsAny(g, win)] -} - # ============================================================================= # Combining collections @@ -717,12 +1245,15 @@ setMethod( #' range, so there is no row to broadcast them onto. Use the accessors #' (\code{\link{susieFit}}, \code{\link{cvResult}}) for those. #' +#' \code{as(x, "GRanges")} is the same conversion. +#' #' @param x A \code{RangedTupleList}. #' @return A \code{GRanges}. #' @examples #' data(qtlFineMappingExample) #' flat <- flattenTupleRanges(qtlFineMappingExample) #' head(names(S4Vectors::mcols(flat))) +#' identical(as(qtlFineMappingExample, "GRanges"), flat) #' @export flattenTupleRanges <- function(x) { if (!methods::is(x, "RangedTupleList")) { @@ -754,6 +1285,16 @@ flattenTupleRanges <- function(x) { ) } +#' @rdname flattenTupleRanges +#' @name coerce,RangedTupleList,GRanges-method +#' @aliases coerce,RangedTupleList,GRanges-method +#' @usage NULL +#' @importFrom methods coerce +#' @exportMethod coerce +setAs("RangedTupleList", "GRanges", function(from) { + flattenTupleRanges(from) +}) + # @noRd .rtlBroadcastColumn <- function(col, reps) { col[reps] @@ -769,7 +1310,8 @@ flattenTupleRanges <- function(x) { #' Re-nest a flattened GRanges into a tuple collection #' #' The inverse of \code{\link{flattenTupleRanges}}: ranges are grouped by the -#' identity tuple they carry and returned to \code{template}'s elements, so the +#' identity tuple they carry -- and, for a tuple split across chromosomes, by +#' chromosome -- and returned to \code{template}'s elements, so the #' collection's class, its per-element payloads and its collection-level slots #' all survive a plyranges round trip. #' @@ -798,8 +1340,17 @@ nestTupleRanges <- function(flat, template) { msg <- glue("`flat` must be a GRanges (got {class(flat)[[1L]]}).") abort(msg) } - keyCols <- .rtlTupleKeyCols(template) - dotted <- map_chr(keyCols, .rtlDotName) + keys <- .rtlNestKeys(flat, template, .rtlTupleKeyCols(template)) + elements <- map(keys$wanted, .rtlPickByKey, flat = flat, have = keys$have) + .rtlRebuild(template, elements, seq_len(length(template))) +} + +# Element and range keys for re-nesting. The identity tuple alone keys an +# element unless several elements share it -- one tuple split across +# chromosomes -- and then the one seqname each of those spans is added on both +# sides. An empty element spans none, so its key is NA and it stays empty. +# @noRd +.rtlNestKeys <- function(flat, template, keyCols) { wanted <- .rtlTupleKeys( mcols(template, use.names = FALSE), keyCols, @@ -807,11 +1358,30 @@ nestTupleRanges <- function(flat, template) { ) have <- .rtlTupleKeys( mcols(flat, use.names = FALSE), - dotted, + map_chr(keyCols, .rtlDotName), n = length(flat) ) - elements <- map(wanted, .rtlPickByKey, flat = flat, have = have) - .rtlRebuild(template, elements, seq_len(length(template))) + shared <- unique(wanted[duplicated(wanted)]) + if (length(shared) == 0L) { + return(list(wanted = wanted, have = have)) + } + list( + wanted = .rtlKeyWithSeqname( + wanted, + is_in(wanted, shared), + map_chr(as.list(template), .rtlElementSeqname) + ), + have = .rtlKeyWithSeqname( + have, + is_in(have, shared), + as.character(seqnames(flat)) + ) + ) +} + +# @noRd +.rtlKeyWithSeqname <- function(keys, add, seqs) { + if_else(add, str_c(keys, seqs, sep = "\r"), keys) } # The identity columns to group by: the atomic mcols the flattener broadcasts. @@ -846,7 +1416,17 @@ nestTupleRanges <- function(flat, template) { # @noRd .rtlPickByKey <- function(key, flat, have) { - flat[have == key] + flat[which(have == key)] +} + +# The one seqname an element sits on. NA for an empty element, which carries +# no coordinate to name. +# @noRd +.rtlElementSeqname <- function(g) { + if (length(g) == 0L) { + return(NA_character_) + } + as.character(seqnames(g))[[1L]] } diff --git a/R/SldscData.R b/R/SldscData.R index bfa440f6..e3ef467e 100644 --- a/R/SldscData.R +++ b/R/SldscData.R @@ -158,25 +158,34 @@ SldscData <- function(annotData, frqData = NULL, traits = list()) { if (is.null(frqData)) { frqData <- tibble() } - obj <- new( + new( "SldscData", annotData = as_tibble(annotData), frqData = as_tibble(frqData), traits = traits ) - validObject(obj) - obj } # ---- accessors ---- #' @rdname annotData #' @export -setMethod("annotData", "SldscData", function(x) x@annotData) +setMethod("annotData", "SldscData", function(x) { + S4Vectors::DataFrame(x@annotData, check.names = FALSE) +}) #' @rdname frqData #' @export -setMethod("frqData", "SldscData", function(x) x@frqData) +setMethod("frqData", "SldscData", function(x) { + S4Vectors::DataFrame(x@frqData, check.names = FALSE) +}) + +# The stored tables as the estimators read them, with dplyr. +# @noRd +.sdAnnot <- function(x) x@annotData + +# @noRd +.sdFrq <- function(x) x@frqData #' @rdname traitNames #' @export @@ -193,28 +202,43 @@ setMethod("annotCols", "SldscData", function(x) { setMethod( "sldscResults", "SldscData", - function(x, trait = NULL, mode = c("single", "joint"), idx = NULL) { + function(x, trait = NULL) { if (is.null(trait)) { return(x@traits) } - mode <- arg_match(mode) - runs <- x@traits[[trait]] - if (is.null(runs)) { - return(NULL) - } - if (mode == "joint") { - return(runs$joint) - } - if (is.null(idx)) { - return(runs$single) - } - if (idx > length(runs$single)) { - return(NULL) + unknown <- setdiff(trait, names(x@traits)) + if (length(unknown) > 0L) { + abort(glue( + "sldscResults: no trait {str_flatten(unknown, ', ')} in this ", + "SldscData. It has: {str_flatten(names(x@traits), ', ')}." + )) } - runs$single[[idx]] + x@traits[trait] } ) +# One trait's run, for the pipelines: its joint run, its single runs, or one +# single run by position -- NULL when the trait, the run kind or that index +# is absent, which those callers turn into their own message. +# @noRd +.sldscRun <- function(x, trait, mode = c("single", "joint"), idx = NULL) { + mode <- arg_match(mode) + runs <- x@traits[[trait]] + if (is.null(runs)) { + return(NULL) + } + if (mode == "joint") { + return(runs$joint) + } + if (is.null(idx)) { + return(runs$single) + } + if (idx > length(runs$single)) { + return(NULL) + } + runs$single[[idx]] +} + #' @rdname SldscData setMethod("show", "SldscData", function(object) { cat("SldscData\n") diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 80ea97db..464e2b6b 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -19,10 +19,13 @@ NULL #' MR computed from \code{fineMappingResult}. #' } #' -#' @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}. +#' @section LD reference compatibility check: Per pair of rows scored +#' together: a QTL input row (TwasWeights or QtlFineMappingResult) that +#' carries an \code{ldReference} must be the same LD reference as the +#' \code{gwasSumStats} rows its region overlaps, and the rows of one GWAS +#' study that a QTL tuple overlaps must share one reference, since its TWAS +#' z reads one LD matrix. Rows that are never scored together may sit on +#' different references. #' 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 @@ -30,8 +33,8 @@ NULL #' 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. +#' QTL input row with no reference (the fit was learned from +#' individual-level data) skips the validation. #' #' @section Output shape: #' A long-format \code{GRanges} with one row per @@ -50,7 +53,14 @@ NULL #' } #' #' @param gwasSumStats A \code{\link{GwasSumStats}} object. Must be QC'd -#' (\code{length(qcInfo(x)) > 0L}). +#' (\code{length(qcOptions(x)) > 0L}). A study may span many rows (one per +#' chromosome or LD block); each QTL tuple is scored once per study, over the +#' statistics of the rows its window overlaps. A tuple's variants outside +#' every loaded block of a study it overlaps are an error where the blocks' +#' ranges were given (\code{regionGiven}, see +#' \code{\linkS4class{GwasSumStats}}), since they lie in a block that was not +#' loaded, and a warning for more than one in a row past a range computed +#' from the GWAS variants. #' @param twasWeights Optional \code{\link{TwasWeights}} carrying per-(study, #' context, trait, method) weights. When supplied, drives the TWAS-Z #' computation. @@ -68,7 +78,9 @@ NULL #' it keeps the highest-\code{metric} method among those clearing both #' 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}. +#' \code{pick_best_model} / \code{update_twas_method}. The metrics describe +#' each fit on all of its variants, so selection warns about a row narrowed +#' since its fit (condition class \code{pecotmrFitCoverage}). #' @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 @@ -83,7 +95,9 @@ NULL #' to the GWAS by (chrom, pos) with ref/alt swaps recognized and the exposure #' effect / weight sign-flipped accordingly; when FALSE, match on exact #' alleles only, so a ref/alt swap is treated as a distinct variant. -#' @return A \code{GRanges} as described above. +#' @return A \code{GRanges} as described above, its \code{seqinfo()} naming +#' the genome build the inputs name (inputs naming different builds are +#' refused). #' @examples #' data(qtlDatasetExample) #' data(gwasSumStatsS4Example) @@ -106,7 +120,11 @@ causalInferencePipeline <- function( "WeightSelectionParam" ) .assertMethodParam(mrParam, "MrParam") - .cipRun( + build <- .inputsBuild( + list(gwasSumStats, twasWeights, fineMappingResult), + "causalInferencePipeline" + ) + res <- .cipRun( gwasSumStats = gwasSumStats, twasWeights = twasWeights, fineMappingResult = fineMappingResult, @@ -115,6 +133,7 @@ causalInferencePipeline <- function( alleleFlip = alleleFlip, mrParam = mrParam ) + .withGenome(res, build) } # Orchestrate the causal-inference pipeline: validate, resolve the QTL work @@ -130,11 +149,7 @@ causalInferencePipeline <- function( mrParam ) { .cipValidateInputs(gwasSumStats, twasWeights, fineMappingResult) - gwasLd <- .cipCheckLdRefs( - gwasSumStats, - twasWeights, - fineMappingResult - ) + .cipCheckLdRefs(gwasSumStats, twasWeights, fineMappingResult) allRows <- .cipResolveWorkList(twasWeights, fineMappingResult) sel <- .cipCvSelection( qtlRows = allRows, @@ -142,14 +157,19 @@ causalInferencePipeline <- function( weightSelectionParam = weightSelectionParam ) qtlRows <- sel$qtlRows - outRows <- list_flatten(map( + tuples <- compact(map( seq_len(nrow(qtlRows)), - .cipScoreQtlTuple, + .cipTupleInputs, qtlRows = qtlRows, twasWeights = twasWeights, - fineMappingResult = fineMappingResult, + fineMappingResult = fineMappingResult + )) + .cipCheckBlockReach(tuples, gwasSumStats) + outRows <- list_flatten(map( + tuples, + .cipScoreQtlTuple, gwasSumStats = gwasSumStats, - gwasLd = gwasLd, + gwasIndex = .rowSpans(gwasSumStats), alleleFlip = alleleFlip, mrParam = mrParam )) @@ -166,10 +186,10 @@ causalInferencePipeline <- function( #' @importFrom checkmate assertClass checkClass .cipValidateInputs <- function(gwasSumStats, twasWeights, fineMappingResult) { assertClass(gwasSumStats, "GwasSumStats") - if (length(qcInfo(gwasSumStats)) == 0L) { + if (length(qcOptions(gwasSumStats)) == 0L) { msg <- glue( "causalInferencePipeline: gwasSumStats has no QC record ", - "(qcInfo() is empty). Call summaryStatsQc() first." + "(qcOptions() is empty). Call summaryStatsQc() first." ) abort(msg) } @@ -198,26 +218,39 @@ causalInferencePipeline <- function( invisible(NULL) } -# Require the twasWeights / fineMappingResult LD sketches to match the GWAS one; -# returns the GWAS LD sketch. +# Require the twasWeights / fineMappingResult rows to share an LD reference +# with each GWAS row they are scored against -- the rows whose regions +# overlap; rows that never meet may sit on different references. # @noRd .cipCheckLdRefs <- function(gwasSumStats, twasWeights, fineMappingResult) { - gwasLd <- ldReference(gwasSumStats) if (!is.null(twasWeights)) { - .cipRequireMatchingLdRefs( - ldReference(twasWeights), - gwasLd, - label = "twasWeights" - ) + .cipRequireMatchingLdRefs(twasWeights, gwasSumStats, "twasWeights") } if (!is.null(fineMappingResult)) { .cipRequireMatchingLdRefs( - ldReference(fineMappingResult), - gwasLd, - label = "fineMappingResult" + fineMappingResult, + gwasSumStats, + "fineMappingResult" ) } - gwasLd + invisible(NULL) +} + +# The LD reference a (QTL tuple, GWAS study) pair's TWAS z reads: the one the +# study's `rows` -- those the tuple overlaps -- share. The z folds their +# variants into a single quadratic form, so they cannot sit on different +# references; that is refused rather than read from one of them. The study's +# other rows are not read and may. +# @noRd +.cipRowsLdRef <- function(gwasSumStats, rows, gStudy) { + .rowsSharedLdRef( + gwasSumStats, + rows, + glue( + "causalInferencePipeline: the rows of GWAS study '{gStudy}' ", + "a QTL tuple overlaps" + ) + ) } # Build the (qtlStudy, context, trait, method) work list + the per-row @@ -275,6 +308,8 @@ causalInferencePipeline <- function( selectionActive = FALSE )) } + # The metrics describe each fit on all of its variants. + .fitCoverageCheckedRows(twasWeights, "causalInferencePipeline()") metricTab <- .cipMethodMetrics( qtlRows, twasWeights, @@ -300,19 +335,12 @@ causalInferencePipeline <- function( list(qtlRows = qtlRows, rsqLookup = rsqLookup, selectionActive = TRUE) } -# Score one QTL tuple against every GWAS study -> a list of result records -# (empty when the tuple has no usable weights). +# One QTL tuple's inputs: its identity, weights and fine-mapping entry, and +# the variants it reads the GWAS at. NULL when the tuple has no usable +# weights. The variants are its weight variants plus its fine-mapping ones, +# which MR reads too. # @noRd -.cipScoreQtlTuple <- function( - qi, - qtlRows, - twasWeights, - fineMappingResult, - gwasSumStats, - gwasLd, - alleleFlip, - mrParam -) { +.cipTupleInputs <- function(qi, qtlRows, twasWeights, fineMappingResult) { tuple <- list( qStudy = qtlRows$qtlStudy[[qi]], qContext = qtlRows$context[[qi]], @@ -329,7 +357,7 @@ causalInferencePipeline <- function( useFmr = qtlRows$useFmrForWeights[[qi]] ) if (is.null(weightsInfo)) { - return(list()) + return(NULL) } fmrEntry <- .cipResolveFmrEntry( fineMappingResult, @@ -338,14 +366,71 @@ causalInferencePipeline <- function( tuple$qTrait, tuple$qMethod ) - compact(map( - seq_len(nrow(gwasSumStats)), - .cipScoreGwasPair, + fmrIds <- if (!is.null(fmrEntry)) { + .grVariantIds(unlist(fmrEntry, use.names = FALSE)) + } + list( tuple = tuple, weightsInfo = weightsInfo, fmrEntry = fmrEntry, + variants = .variantIdsToGRanges( + unique(c(weightsInfo$variantIds, fmrIds)), + what = "causalInferencePipeline variant id" + ) + ) +} + +# Each tuple's variants against the LD blocks of the GWAS studies they +# overlap (.checkGwasBlockReach()). +# @noRd +.cipCheckBlockReach <- function(tuples, gwasSumStats) { + .checkGwasBlockReach( + set_names(map(tuples, "variants"), map_chr(tuples, .cipTupleLabel)), + gwasSumStats, + "causalInferencePipeline", + "QTL tuples" + ) +} + +# @noRd +.cipTupleLabel <- function(input) { + t <- input$tuple + .fmrTupleLabel( + "QTL", + list( + study = t$qStudy, + context = t$qContext, + trait = t$qTrait, + method = t$qMethod + ) + ) +} + +# Score one QTL tuple against every GWAS study it overlaps -> a list of +# result records (empty when it overlaps no GWAS row). Each study is scored +# once, over just the rows the tuple's window -- the span of its variants -- +# overlaps: a study split by chromosome or LD block has many rows, and +# pairing the tuple with every one of them scored it once per row. +# `gwasIndex` is .rowSpans(gwasSumStats), built once for the run. +# @noRd +.cipScoreQtlTuple <- function( + input, + gwasSumStats, + gwasIndex, + alleleFlip, + mrParam +) { + window <- range(input$variants) + rows <- unique(gwasIndex$rows[.overlapsOnShared(gwasIndex$spans, window)]) + studies <- as.character(gwasSumStats$study)[rows] + compact(imap( + split(rows, factor(studies, levels = unique(studies))), + .cipScoreGwasPair, + tuple = input$tuple, + weightsInfo = input$weightsInfo, + fmrEntry = input$fmrEntry, gwasSumStats = gwasSumStats, - gwasLd = gwasLd, + window = window, alleleFlip = alleleFlip, mrParam = mrParam )) @@ -376,23 +461,29 @@ causalInferencePipeline <- function( } # Score one (qtl tuple, gwas study) pair -> a result record, or NULL when the -# TWAS Z cannot be computed (too little overlap). +# TWAS Z cannot be computed (too little overlap). `rows` are the study's rows +# the tuple's window overlaps; only their statistics inside the window are +# read, so a gene whose weights cross an LD-block boundary is scored once, +# over every block it reaches. # @noRd .cipScoreGwasPair <- function( - gi, + rows, + gStudy, tuple, weightsInfo, fmrEntry, gwasSumStats, - gwasLd, + window, alleleFlip, mrParam ) { - gStudy <- as.character(gwasSumStats$study)[[gi]] - gdf <- as.data.frame( - gwasSumStats, - studyName = gStudy, - require = c("SNP", "Z") + gwasLd <- .cipRowsLdRef(gwasSumStats, rows, gStudy) + gdf <- .entryToSumstatDf( + .ssStitchElements(gwasSumStats, rows, window), + require = c("SNP", "Z"), + derive = "none", + keepChrPrefix = TRUE, + label = glue("GwasSumStats[{gStudy}]") ) twasOut <- .cipComputeTwasZ( weights = weightsInfo$weights, @@ -527,12 +618,13 @@ causalInferencePipeline <- function( # Internal helpers # ============================================================================= -# Check two LD sketches for reference-panel compatibility. Thin wrapper over -# the shared `.requireMatchingLdRefs` helper (R/ld.R). -.cipRequireMatchingLdRefs <- function(qtlLd, gwasLd, label) { - .requireMatchingLdRefs( - qtlLd, - gwasLd, +# Check the QTL-side rows against the GWAS rows they overlap for +# reference-panel compatibility. Thin wrapper over the shared +# `.requireOverlapLdRefs` helper (R/ld.R). +.cipRequireMatchingLdRefs <- function(qtl, gwasSumStats, label) { + .requireOverlapLdRefs( + qtl, + gwasSumStats, pipelineName = "causalInferencePipeline", label = label ) @@ -566,6 +658,9 @@ causalInferencePipeline <- function( # with a named $metrics vector (corr, rsq, adj_rsq, pval, RMSE, MAE); a bare # metrics vector / data frame is tolerated too. `which` is a vector of candidate # metric names; the first present is used. Returns NA when no usable metric. +# Read from the row, not through cvResult(x, ...): .cipCvSelection() has +# already warned once about narrowed rows, which the accessor would repeat +# for every row and metric. # @noRd #' @importFrom rlang try_fetch .cipCvMetric <- function( @@ -578,11 +673,7 @@ causalInferencePipeline <- function( ) { perf <- try_fetch( cvResult( - twasWeights, - studyName = studyName, - context = context, - trait = trait, - method = method + .twrSelectRowParts(twasWeights, studyName, context, trait, method) ), error = function(cnd) NULL ) @@ -1345,9 +1436,8 @@ causalInferencePipeline <- function( # Convert the assembled result data.frame to a GRanges with mcols. .cipDfToGranges <- function(df) { - chr <- withChrPrefix(df$chrom) gr <- GenomicRanges::GRanges( - seqnames = chr, + seqnames = df$chrom, ranges = IRanges::IRanges( start = as.integer(df$startPos), end = as.integer(df$endPos) diff --git a/R/colocPipeline.R b/R/colocPipeline.R index d297e226..9bd3073e 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -203,8 +203,9 @@ setClass( #' @return \code{GwasFineMappingParam} returns a #' \code{GwasFineMappingParam} object, a \code{\link{MethodParam}}. #' Each accessor returns that setting's value --- for the three nested -#' bundles, the \code{MethodParam} itself --- and each replacement form -#' returns a modified copy. +#' bundles, the \code{MethodParam} itself. Change a setting with +#' \code{x$ <- value} (the field for \code{fineMappingMethods()} +#' is \code{methods}), which returns a modified copy. #' @examples #' GwasFineMappingParam( #' credibleSetParam = CredibleSetParam(coverage = 0.9) @@ -282,9 +283,40 @@ GwasFineMappingParam <- function( #' inline fine-mapping. #' } #' -#' @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}. +#' @section A region over several LD blocks: Each first-side region is +#' colocalized with ONE fit per second-side study and method, however many +#' of a GWAS study's LD blocks it reaches -- scoring it against each block +#' separately would split one region into as many colocalizations as it +#' has blocks, each truncating the region's effects to one block's +#' variants. +#' \itemize{ +#' \item A \code{GwasSumStats} is fine-mapped once per set of rows a +#' region reaches, their statistics stitched together on their one +#' LD reference (rows on different references are refused). A +#' region inside one block reads that block's fit. +#' \item A \code{GwasFineMappingResult} was fine-mapped block by block. +#' Assuming no LD between blocks, the blocks a region reaches +#' collapse into one fit: every block's effects, each confined to +#' its own block (a Bayes factor of zero elsewhere), numbered on +#' from the blocks before it in row order. +#' } +#' The fit's \code{blockId} is then the stretch the blocks' ranges cover, +#' as \code{"chrom_start_end"} (see \code{region} in +#' \code{\linkS4class{GwasSumStats}}). +#' +#' A region's variants that lie outside every loaded block of a GWAS +#' study it overlaps are left out of that fit, a sign that a block it +#' reaches was not loaded. Where those blocks' ranges were given +#' (\code{regionGiven}), the variants lie in a block that was not loaded, +#' and that is an error. Where the ranges are the span of the GWAS +#' variants, the variants may only be ones the GWAS lacks, so more than one +#' in a row past a block is a warning. +#' +#' @section LD reference compatibility check: Rows can sit on different LD +#' references, so the check is per pair of rows coloc scores against each +#' other -- a QTL row and a GWAS row whose regions overlap. Where the QTL +#' row carries a reference, it must be the same LD reference as the GWAS +#' row's; rows that are never paired may differ. #' 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 @@ -293,9 +325,9 @@ GwasFineMappingParam <- function( #' 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. +#' any of those, is a hard error. When a first-side row has no reference +#' (individual-level fit), the validation is skipped for it and the second +#' side's panel is what the result carries forward for its pairs. #' #' @param qtlFineMappingResult The first side: a #' \code{\link{QtlFineMappingResult}} or a @@ -332,13 +364,15 @@ GwasFineMappingParam <- function( #' two different things. #' @param returnGwasFineMapping Logical. When \code{TRUE}, attach the #' fine-mapping result computed from \code{gwasInput} on the returned object -#' as attribute \code{"gwasFineMapping"}. Default \code{FALSE}. +#' as attribute \code{"gwasFineMapping"}: for a \code{GwasSumStats}, one fit +#' per set of rows a first-side region reaches. Default \code{FALSE}. #' @param enrichment Optional data.frame of per-pair enrichment factors with #' columns \code{gwasStudy}, \code{qtlStudy}, \code{qtlContext}, #' \code{enrichment}, and optionally \code{gwasContext} / \code{gwasTrait} -#' (which the join uses when present, and which -#' \code{\link{qtlEnrichmentPipeline}} emits for a QTL outcome side). Output -#' of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is +#' / \code{gwasMethod} / \code{qtlMethod} (which the join uses when +#' present; \code{\link{qtlEnrichmentPipeline}} emits all four, the context +#' and trait set for a QTL outcome side). Output of +#' \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is #' scored by enloc rather than coloc: the priors come from that table's #' \code{colocP1} / \code{colocP2} / \code{colocP12} columns, and the #' report gains \code{RCP} and \code{LCP}. Pairs without a matching @@ -352,7 +386,9 @@ GwasFineMappingParam <- function( #' missing variants in the GWAS \code{SumStats} and the QTL fine-mapping #' input has additional variants; (2) the GWAS fine-mapping result contains #' variants not present in the QTL fine-mapping result. Pass \code{FALSE} to -#' use the FMRs as supplied. +#' use the FMRs as supplied; each fit is then scored whole, so a row +#' narrowed since its fit warns (condition class +#' \code{pecotmrFitCoverage}). #' #' How much of each effect's posterior survived that restriction is reported #' per result row as \code{qtlRetainedMass} / \code{gwasRetainedMass}; a low @@ -369,7 +405,7 @@ GwasFineMappingParam <- function( #' prior probabilities are set through \code{priors} instead, since the #' enrichment adjustment reads them too. #' @return A \code{\linkS4class{ColocResult}}: one element per tested -#' (first-side credible set, second-side credible set, block) pair, holding +#' (first-side credible set, second-side credible set) pair, holding #' that pair's aligned variants with their \code{SNP.PP.H4}. Pair-level #' metadata carries the identity columns (\code{study}, \code{context}, #' \code{trait}, \code{method}, \code{gwasStudy}, \code{gwasContext}, @@ -388,9 +424,10 @@ GwasFineMappingParam <- function( #' is what readers of enloc output expect to find. #' #' Project it with \code{\link{colocPairs}} (the flat table this -#' pipeline used to return, also available as \code{as.data.frame}), -#' \code{\link{colocVariants}}, \code{\link{colocCredibleSets}} or -#' \code{\link{colocGenes}}. +#' pipeline used to return), \code{\link{colocVariants}}, +#' \code{\link{colocCredibleSets}} or \code{\link{colocGenes}}. Its +#' \code{seqinfo()} names the genome build the two sides name; sides +#' naming different builds are refused. #' @examples #' data(qtlFineMappingLbfExample) #' data(gwasFineMappingLbfExample) @@ -440,7 +477,7 @@ colocPipeline <- function( returnGwasFineMapping = returnGwasFineMapping ) if (length(gwasLbfByPair) == 0L) { - return(exec(.colocEarlyReturn, !!!shape)) + return(.withGenome(exec(.colocEarlyReturn, !!!shape), prepared$build)) } results <- .colocScoreAll( prepared, @@ -450,7 +487,7 @@ colocPipeline <- function( priors = priors, alleleFlip = alleleFlip ) - exec(.colocFinalize, results, !!!shape) + .withGenome(exec(.colocFinalize, results, !!!shape), prepared$build) } # Score every QTL tuple against the pre-extracted GWAS LBF matrices. @@ -463,11 +500,16 @@ colocPipeline <- function( priors, alleleFlip ) { + qtlKeys <- if (!is.null(prepared$pairing)) { + .colocRowKeys(prepared$qtlFineMappingResult) + } list_flatten(map( seq_len(nrow(prepared$qtlFineMappingResult)), .colocScoreQtlTuple, qtlFineMappingResult = prepared$qtlFineMappingResult, gwasLbfByPair = gwasLbfByPair, + pairing = prepared$pairing, + qtlKeys = qtlKeys, colocLbfFilterParam = colocLbfFilterParam, useEnrichment = prepared$useEnrichment, enrichment = enrichment, @@ -493,6 +535,11 @@ colocPipeline <- function( colocLbfFilterParam, priorsMissing ) { + # The genome build the two sides share, checked before any work. + build <- .inputsBuild( + list(qtlFineMappingResult, gwasInput), + "colocPipeline" + ) .colocAssertGroups(priors, colocLbfFilterParam, methodArgs) .colocRefusePriorsWithEnrichment(priors, enrichment, priorsMissing) useEnrichment <- !is.null(enrichment) @@ -502,21 +549,25 @@ colocPipeline <- function( enrichment = enrichment, useEnrichment = useEnrichment ) - rawGwasFmr <- .colocResolveGwasFmr(gwasInput, gwasFineMappingParam) - .colocRequireMatchingLdRefs( - ldReference(qtlFineMappingResult), - ldReference(rawGwasFmr) + .colocCheckBlockReach(qtlFineMappingResult, gwasInput) + resolved <- .colocResolveGwasFmr( + gwasInput, + gwasFineMappingParam, + qtlFineMappingResult ) + .colocRequireMatchingLdRefs(qtlFineMappingResult, resolved$fmr) adjusted <- .colocMaybeAdjustPips( adjustPips = adjustPips, qtlFineMappingResult = qtlFineMappingResult, - gwasFmr = rawGwasFmr + gwasFmr = resolved$fmr ) list( ColocOptions = .colocEngineArgs(methodArgs, priors), useEnrichment = useEnrichment, qtlFineMappingResult = adjusted$qtlFineMappingResult, - gwasFmr = adjusted$gwasFmr + gwasFmr = adjusted$gwasFmr, + pairing = resolved$pairing, + build = build ) } @@ -583,7 +634,15 @@ colocPipeline <- function( # @noRd .colocValidateEnrichmentKeys <- function(enrichment) { idCols <- intersect( - c("gwasStudy", "gwasContext", "gwasTrait", "qtlStudy", "qtlContext"), + c( + "gwasStudy", + "gwasContext", + "gwasTrait", + "gwasMethod", + "qtlStudy", + "qtlContext", + "qtlMethod" + ), colnames(enrichment) ) ids <- select(as_tibble(enrichment), all_of(idCols)) @@ -598,26 +657,117 @@ 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). +# when summary statistics are passed, whichever flavour they are), with the +# pairing that says which of its fits each first-side row is scored against +# -- NULL when that is decided by shared variants. +# +# A GWAS study split into LD blocks is fine-mapped once per set of blocks a +# first-side region reaches, those blocks' statistics stitched together: +# scoring a region against each block's own fit would split one region into +# as many colocalizations as it has blocks. A region inside one block reads +# that block's fit. # @noRd -.colocResolveGwasFmr <- function(gwasInput, gwasFineMappingParam) { +.colocResolveGwasFmr <- function( + gwasInput, + gwasFineMappingParam, + qtlFineMappingResult +) { 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(gwasFineMappingParam, class(gwasInput)[[1L]]) - return(gwasInput) + return(list(fmr = gwasInput, pairing = NULL)) } .assertMethodParam( gwasFineMappingParam, "GwasFineMappingParam" ) - if (length(qcInfo(gwasInput)) == 0L) { + if (length(qcOptions(gwasInput)) == 0L) { msg <- glue( "colocPipeline: gwasInput ({class(gwasInput)[[1L]]}) has no QC ", "record. Call summaryStatsQc() first." ) abort(msg) } + if (!methods::is(gwasInput, "GwasSumStats")) { + return(list( + fmr = .colocFineMapGwas(gwasInput, gwasFineMappingParam), + pairing = NULL + )) + } + sets <- .colocQtlRowSets(gwasInput, qtlFineMappingResult) + list( + fmr = .colocFineMapUnions(gwasInput, sets, gwasFineMappingParam), + pairing = tibble( + qtlKey = .colocRowKeys(qtlFineMappingResult)[sets$qtlRow], + key = str_c(sets$study, sets$blockId, sep = "\r") + ) + ) +} + +# Each first-side row's variants against the LD blocks of the GWAS studies it +# overlaps (.checkGwasBlockReach()). Only a GWAS second side has blocks. +# @noRd +.colocCheckBlockReach <- function(qtlFineMappingResult, gwasInput) { + if ( + !methods::is(gwasInput, "GwasSumStats") && + !methods::is(gwasInput, "GwasFineMappingResult") + ) { + return(invisible(NULL)) + } + side <- .fmrSideName(qtlFineMappingResult) + labels <- map_chr( + seq_len(nrow(qtlFineMappingResult)), + .colocUnitLabel, + fmr = qtlFineMappingResult, + side = side + ) + .checkGwasBlockReach( + set_names(as.list(qtlFineMappingResult), labels), + gwasInput, + "colocPipeline", + "regions of `qtlFineMappingResult`" + ) +} + +# @noRd +.colocUnitLabel <- function(ri, fmr, side) { + .fmrTupleLabel( + side, + .colocTupleIdentity(fmr, ri), + block = .fmrIdentityAt(fmr, "blockId", ri) + ) +} + +# A first-side row's identity: its tuple, its block and the one chromosome it +# sits on. The pairing keys rows by this rather than by index, since the PIP +# reconciliation that follows drops rows sharing no variant with the other +# side, and an index would then point at the wrong row. +# @noRd +.colocRowKeys <- function(fmr) { + cols <- intersect( + c( + "study", + "context", + "trait", + "method", + "blockId", + "jointStudies", + "jointContexts", + "jointTraits" + ), + .rtlTupleKeyCols(fmr) + ) + str_c( + .rtlTupleKeys(mcols(fmr, use.names = FALSE), cols, n = nrow(fmr)), + map_chr(as.list(fmr), .rtlElementSeqname), + sep = "\r" + ) +} + +# Fine-map summary statistics with the bundle's settings. +# @noRd +.colocFineMapGwas <- function(gwasInput, gwasFineMappingParam) { # The bundle's terminal: fineMappingPipeline takes these as its own # arguments, so it is unrolled once, here. withSusieInf <- gwasFineMappingParam$initializeWithSusieInf %||% TRUE @@ -634,6 +784,155 @@ colocPipeline <- function( ) } +# For each first-side row, the rows of each GWAS study its span reaches: one +# row per (first-side row, study), with the block id the fit of those rows +# goes by. Empty rows have no span and are never reached. +# @noRd +.colocQtlRowSets <- function(gws, qtlFineMappingResult) { + q <- .rowSpans(qtlFineMappingResult) + sets <- list_rbind(map( + seq_along(q$rows), + .colocRowSetsOf, + q = q, + index = .rowSpans(gws), + gws = gws, + regions = .rowRegions(gws) + )) + if (is.null(sets) || nrow(sets) == 0L) { + return(tibble( + qtlRow = integer(0), + study = character(0), + rows = list(), + blockId = character(0) + )) + } + sets +} + +# @noRd +.colocRowSetsOf <- function(k, q, index, gws, regions) { + hits <- sort(unique( + index$rows[.overlapsOnShared(index$spans, q$spans[k])] + )) + if (length(hits) == 0L) { + return(NULL) + } + studies <- as.character(gws$study)[hits] + byStudy <- unname(split(hits, factor(studies, levels = unique(studies)))) + tibble( + qtlRow = rep(q$rows[[k]], length(byStudy)), + study = unique(studies), + rows = byStudy, + blockId = map_chr( + byStudy, + .colocUnionBlockId, + gws = gws, + regions = regions + ) + ) +} + +# The block id a set of a study's rows is fine-mapped under. fineMappingPipeline +# carries it over as it is, which is what lets each first-side row find its +# own fit again afterwards. +# @noRd +.colocUnionBlockId <- function(rows, gws, regions) { + .colocMergedBlockId( + as.character(gws$blockId)[rows], + regions$region[rows] + ) +} + +# Fine-map each distinct set of rows once, however many first-side rows reach +# it. +# @noRd +.colocFineMapUnions <- function(gws, sets, gwasFineMappingParam) { + unions <- slice( + sets, + which(!duplicated(str_c(sets$study, sets$blockId, sep = "\r"))) + ) + if (nrow(unions) == 0L) { + return(GwasFineMappingResult( + studyName = character(0), + method = character(0), + entry = list() + )) + } + .colocFineMapGwas(.colocUnionSumStats(gws, unions), gwasFineMappingParam) +} + +# One row per set: its rows' statistics stitched together, on their one LD +# reference, under the set's block id. Study-level values are read off the +# set's first row, which every row of a study shares. +# @noRd +.colocUnionSumStats <- function(gws, unions) { + first <- map_int(unions$rows, 1L) + md <- mcols(gws) + stitched <- GwasSumStats( + studyName = unions$study, + entry = map(unions$rows, .ssStitchElements, x = gws), + genome = discard(unique(GenomeInfoDb::genome(gws)), is.na)[[1L]], + ldReference = map2( + unions$rows, + unions$study, + .colocUnionLdRef, + gws = gws + ), + varY = as.numeric(md$varY)[first], + nCase = .colocStudyValue(md, "nCase", first), + nControl = .colocStudyValue(md, "nControl", first), + nSample = .colocStudyValue(md, "nSample", first), + qcOptions = qcOptions(gws), + blockId = unions$blockId + ) + .withRegionColumns( + stitched, + .colocUnionRegions(unions$rows, .rowRegions(gws)) + ) +} + +# Each set's block range: the stretch its rows' ranges cover, given only when +# every one of them was. +# @noRd +.colocUnionRegions <- function(sets, regions) { + list( + region = unname(unlist(.rtlBindElements( + map(sets, .colocSetRange, regions = regions) + ))), + regionGiven = map_lgl(sets, .colocSetGiven, regions = regions) + ) +} + +# @noRd +.colocSetRange <- function(rows, regions) { + range(regions$region[rows]) +} + +# @noRd +.colocSetGiven <- function(rows, regions) { + all(regions$regionGiven[rows]) +} + +# @noRd +.colocStudyValue <- function(md, nm, rows) { + if (!is_in(nm, colnames(md))) { + return(NULL) + } + as.numeric(md[[nm]])[rows] +} + +# @noRd +.colocUnionLdRef <- function(rows, study, gws) { + .rowsSharedLdRef( + gws, + rows, + glue( + "colocPipeline: the rows of GWAS study '{study}' a QTL region ", + "reaches" + ) + ) +} + # `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. @@ -673,6 +972,10 @@ colocPipeline <- function( # intersectVariants() gives, and it replaces the older hand-rolled pass which # adjusted each side to the UNION of the other's variants -- a union is not an # intersection, so the two sides could still end up on different sets. +# +# The adjustment restricts each fit to the shared variants, which its row +# then holds exactly. Only a fit scored as supplied can describe variants its +# row no longer holds, and that warns. # @noRd .colocMaybeAdjustPips <- function( adjustPips, @@ -683,27 +986,17 @@ colocPipeline <- function( qtlFineMappingResult = qtlFineMappingResult, gwasFmr = gwasFmr ) - if (!isTRUE(adjustPips)) { + if (nrow(qtlFineMappingResult) == 0L || nrow(gwasFmr) == 0L) { return(unchanged) } - if (nrow(qtlFineMappingResult) == 0L || nrow(gwasFmr) == 0L) { + if (!isTRUE(adjustPips)) { + .fitCoverageCheckedAll(unchanged, "colocPipeline()") return(unchanged) } both <- intersectVariants(qtlFineMappingResult, gwasFmr) list(qtlFineMappingResult = both$x, gwasFmr = both$y) } -# 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 -# .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 -.colocLdRef <- function(qtlFineMappingResult, gwasFmr) { - ldReference(qtlFineMappingResult) %||% ldReference(gwasFmr) -} - # Empty-result early return (attaching the GWAS fine-mapping when requested). # @noRd .colocEarlyReturn <- function( @@ -713,19 +1006,18 @@ colocPipeline <- function( gwasInput, returnGwasFineMapping ) { - out <- .colocEmptyResult( - enriched = useEnrichment, - ldReference = .colocLdRef(qtlFineMappingResult, gwasFmr) - ) + out <- .colocEmptyResult(enriched = useEnrichment) .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } -# Score one QTL tuple against every pre-extracted GWAS pair -> summary rows. +# Score one QTL tuple against each second-side fit it reaches -> summary rows. # @noRd .colocScoreQtlTuple <- function( qi, qtlFineMappingResult, gwasLbfByPair, + pairing, + qtlKeys, colocLbfFilterParam, useEnrichment, enrichment, @@ -748,7 +1040,13 @@ colocPipeline <- function( effect = qLbfInfo$effect ) compact(map( - gwasLbfByPair, + .colocGwasRecordsFor( + qtlKeys[[qi]], + colnames(qLbfInfo$lbf), + gwasLbfByPair, + pairing, + alleleFlip + ), .colocScorePairAt, qLbfInfo = qLbfInfo, q = scored, @@ -769,7 +1067,8 @@ colocPipeline <- function( ident, list( parts = .fmrRowParts(fmr, qi), - label = .fmrTupleLabel(.fmrSideName(fmr), ident) + label = .fmrTupleLabel(.fmrSideName(fmr), ident), + ldReference = .rowLdRef(fmr, qi) ) ) } @@ -853,9 +1152,16 @@ colocPipeline <- function( # $results is the per-variant layer that process_coloc_results() used to # consume and that this pipeline silently dropped. It is pivoted here, the # only place that knows which results column belongs to which summary row. + # The pair's LD reference rides along for colocCredibleSets()' purity: + # the two sides' are required to match, but a QTL side fit on + # individual-level data has none, and then the GWAS side's is the one. list( rows = rows, - variants = .crPivotColocResults(pairRes$results, nrow(rows)) + variants = .crPivotColocResults(pairRes$results, nrow(rows)), + ldReference = rep( + list(q$ldReference %||% gInfo$ldReference), + nrow(rows) + ) ) } @@ -934,12 +1240,15 @@ colocPipeline <- function( list(summary = summary, results = .colocEnlocResults(scored, aligned)) } -# One (QTL effect, GWAS effect) pair, which is enloc's signal cluster. +# One (QTL effect, GWAS effect) pair, which is enloc's signal cluster. The +# LBF matrices hold SuSiE's natural-log Bayes factors and enloc reads log10 +# ones, so they are converted here; read as log10 unconverted, every cluster's +# PIPs came out sharper than SuSiE's own alpha. # @noRd .colocEnlocOneEffectPair <- function(i, j, aligned, priors) { .enlocScoreEffectPair( - qtlLog10Bf = aligned$qtl[i, ], - gwasLog10Bf = aligned$gwas[j, ], + qtlLog10Bf = aligned$qtl[i, ] / log(10), + gwasLog10Bf = aligned$gwas[j, ] / log(10), priors = priors ) } @@ -1048,11 +1357,7 @@ colocPipeline <- function( gwasInput, returnGwasFineMapping ) { - out <- .colocAssemble( - results, - useEnrichment, - .colocLdRef(qtlFineMappingResult, gwasFmr) - ) + out <- .colocAssemble(results, useEnrichment) .colocAttachGwasFm(out, returnGwasFineMapping, gwasInput, gwasFmr) } @@ -1066,18 +1371,20 @@ colocPipeline <- function( `attr<-`(out, "gwasFineMapping", gwasFmr) } -# Row-bind + column-order the per-pair summary rows (empty result when none). +# Row-bind + column-order the per-pair summary rows (empty result when none), +# each pair on the LD reference it was scored against. # @noRd -.colocAssemble <- function(results, useEnrichment, ldReference = NULL) { +.colocAssemble <- function(results, useEnrichment) { if (length(results) == 0L) { - return(.colocEmptyResult( - enriched = useEnrichment, - ldReference = ldReference - )) + return(.colocEmptyResult(enriched = useEnrichment)) } rows <- bind_rows(map(map(results, "rows"), .colocStandardiseRow)) variants <- list_c(map(results, "variants")) - ColocResult(.colocOrderColumns(rows, useEnrichment), variants, ldReference) + ColocResult( + .colocOrderColumns(rows, useEnrichment), + variants, + ldReference = list_flatten(map(results, "ldReference")) + ) } # Identity columns first, then everything coloc produced. @@ -1104,12 +1411,19 @@ colocPipeline <- function( # Internal helpers # ============================================================================= -# LD-sketch compatibility check. Thin wrapper over the shared -# `.requireMatchingLdRefs` helper (R/ld.R). Shared with -# qtlEnrichmentPipeline. +# LD-sketch compatibility check over the QTL / GWAS row pairs coloc scores +# against each other -- those whose regions overlap -- each of which must +# share an LD reference; rows that are never paired may sit on different +# ones. Thin wrapper over the shared `.requireOverlapLdRefs` helper +# (R/ld.R). # @noRd -.colocRequireMatchingLdRefs <- function(qtlLd, gwasLd) { - .requireMatchingLdRefs(qtlLd, gwasLd, pipelineName = "colocPipeline") +.colocRequireMatchingLdRefs <- function(qtlFineMappingResult, gwasFmr) { + .requireOverlapLdRefs( + qtlFineMappingResult, + gwasFmr, + pipelineName = "colocPipeline", + label = "qtlFineMappingResult" + ) } # SuSiE credible-set concentration filter. Given a trimmed SuSiE fit @@ -1183,7 +1497,10 @@ colocPipeline <- function( # The fit's own effect indices, which -- unlike coloc's idx1 / idx2 -- # are stable across calls and blocks, so they are what identifies a # credible set in the result. - effect = keep + effect = keep, + # How many effects the fit has before filtering, which is what a + # collapse of several blocks numbers the next block's effects after. + nEffects = nrow(allRows) ) } @@ -1277,13 +1594,15 @@ colocPipeline <- function( as.numeric(mass) } -# The entry's variant ids, when the matrix does not already name its columns. +# The ids the fit was made with, when the matrix does not already name its +# columns: the columns are the fit's variables, which a row narrowed since no +# longer holds all of. # @noRd .colocLbfNamesFrom <- function(lbfMatrix, parts) { if (!is.null(colnames(lbfMatrix)) && !any(is.na(colnames(lbfMatrix)))) { return(lbfMatrix) } - vids <- .fmrPartsVariantIds(parts) + vids <- .partsFitIds(parts) if (length(vids) != ncol(lbfMatrix)) { return(lbfMatrix) } @@ -1316,11 +1635,28 @@ colocPipeline <- function( .colocGwasLbfAt, gwasFmr = gwasFmr, blockIds = .colocGwasBlockIds(gwasFmr), + regions = .rowRegions(gwasFmr)$region, + fits = .colocGwasFitKeys(gwasFmr), side = .fmrSideName(gwasFmr), colocLbfFilterParam = colocLbfFilterParam )) } +# Which fit each second-side row belongs to. A GWAS fit is every LD block of +# one (study, method), and those rows are what a QTL region's blocks are +# collapsed from; a QTL row is a fit of its own. +# @noRd +.colocGwasFitKeys <- function(gwasFmr) { + if (!methods::is(gwasFmr, "GwasFineMappingResult")) { + return(as.character(seq_len(nrow(gwasFmr)))) + } + str_c( + .fmrIdentityColumn(gwasFmr, "study"), + .fmrIdentityColumn(gwasFmr, "method"), + sep = "\r" + ) +} + # One second-side row's LBF matrix plus its identity, or NULL when the row has # no usable LBF. # @noRd @@ -1328,6 +1664,8 @@ colocPipeline <- function( ri, gwasFmr, blockIds, + regions, + fits, side, colocLbfFilterParam ) { @@ -1348,12 +1686,133 @@ colocPipeline <- function( lbf = info$lbf, retainedMass = info$retainedMass, effect = info$effect, + nEffects = info$nEffects, blockId = blockId, - label = label + fit = fits[[ri]], + region = regions[ri], + label = label, + side = side, + ldKey = .ldRefKeys(gwasFmr)[[ri]], + ldReference = .rowLdRef(gwasFmr, ri) ) ) } +# The second-side fits one QTL tuple is scored against: one record per fit, +# however many LD blocks it spans. With a `pairing` -- the GWAS fine-mapped +# here, once per set of rows a QTL region reaches -- that is the tuple's own +# fits. Otherwise it is every fit sharing variants with the tuple, its +# overlapped blocks collapsed into one. +# @noRd +.colocGwasRecordsFor <- function( + qKey, + qIds, + gwasLbfByPair, + pairing, + alleleFlip +) { + if (!is.null(pairing)) { + return(keep( + gwasLbfByPair, + .colocRecordKeyIn, + keys = pairing$key[pairing$qtlKey == qKey] + )) + } + hits <- keep( + gwasLbfByPair, + .colocSharesVariants, + qIds = qIds, + alleleFlip = alleleFlip + ) + fits <- map_chr(hits, "fit") + unname(map( + split(hits, factor(fits, levels = unique(fits))), + .colocCollapseBlocks + )) +} + +# @noRd +.colocRecordKeyIn <- function(rec, keys) { + is_in(str_c(rec$study, rec$blockId, sep = "\r"), keys) +} + +# @noRd +.colocSharesVariants <- function(rec, qIds, alleleFlip) { + m <- matchVariants(qIds, colnames(rec$lbf), allowFlip = alleleFlip) + length(m$idxA) > 0L +} + +# The LD blocks of one GWAS fit a QTL region reaches, collapsed into the one +# fit they make when there is no LD between blocks. The RSS likelihood then +# factorizes over blocks, so an effect fitted in one block carries no evidence +# about another's variants: the collapsed fit holds every block's effects, +# each confined to its own block -- an LBF of -Inf, a Bayes factor of zero, +# elsewhere -- and numbered on from the blocks before it, in row order. A fit +# the region reaches in one block is that block's record as it is. +# @noRd +.colocCollapseBlocks <- function(recs) { + if (length(recs) == 1L) { + return(recs[[1L]]) + } + ids <- unique(list_c(map(recs, .colocLbfIds))) + offsets <- cumsum(c(0L, map_int(recs, "nEffects")))[seq_along(recs)] + blockId <- .colocMergedBlockId( + map_chr(recs, "blockId"), + unlist(.rtlBindElements(map(recs, "region"))) + ) + list_assign( + recs[[1L]], + lbf = exec(rbind, !!!map(recs, .colocPadLbf, ids = ids)), + retainedMass = list_c(map(recs, "retainedMass")), + effect = list_c(map2(recs, offsets, .colocShiftEffects)), + nEffects = sum(map_int(recs, "nEffects")), + blockId = blockId, + label = .fmrTupleLabel( + recs[[1L]]$side, + recs[[1L]][c("study", "context", "trait", "method")], + block = blockId + ), + ldReference = .colocMergedLdRef(recs) + ) +} + +# @noRd +.colocLbfIds <- function(rec) { + colnames(rec$lbf) +} + +# One block's LBF rows over the collapsed fit's variants: -Inf off the block. +# @noRd +.colocPadLbf <- function(rec, ids) { + out <- matrix(-Inf, nrow(rec$lbf), length(ids), dimnames = list(NULL, ids)) + out[, colnames(rec$lbf)] <- rec$lbf + out +} + +# @noRd +.colocShiftEffects <- function(rec, offset) { + rec$effect + offset +} + +# The blocks' shared LD reference, or none when they sit on different ones. +# @noRd +.colocMergedLdRef <- function(recs) { + if (n_distinct(map_chr(recs, "ldKey")) > 1L) { + return(NULL) + } + recs[[1L]]$ldReference +} + +# The block id of a fit over several LD blocks: the stretch their windows +# cover, as "chrom_start_end". A single block keeps its own. +# @noRd +.colocMergedBlockId <- function(blockIds, regions) { + if (length(blockIds) == 1L) { + return(blockIds[[1L]]) + } + .rtlOneRangeKey(range(regions)) +} + # The LD block each GWAS fine-mapping row was computed on. The element's own # range is the identity; an explicit `blockId` (which keys the external block # manifest, and so carries the true block BOUNDARIES rather than the span of @@ -1395,7 +1854,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, ldReference = NULL) { +.colocEmptyResult <- function(enriched = FALSE) { base <- tibble( study = character(0), context = character(0), @@ -1419,11 +1878,7 @@ colocPipeline <- function( qtlRetainedMass = numeric(0), gwasRetainedMass = numeric(0) ) - ColocResult( - mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), - list(), - ldReference = ldReference - ) + ColocResult(mutate(base, !!!.colocEnrichmentCols(enriched, NULL)), list()) } # Look up this pair's enrichment factor in the user-supplied enrichment table. @@ -1482,8 +1937,10 @@ colocPipeline <- function( gwasStudy = gInfo$study, gwasContext = gInfo$context, gwasTrait = gInfo$trait, + gwasMethod = gInfo$method, qtlStudy = q$study, - qtlContext = q$context + qtlContext = q$context, + qtlMethod = q$method ) wanted[is_in(names(wanted), colnames(enrichment))] } @@ -1582,94 +2039,36 @@ colocPipeline <- function( } # --- GwasFineMappingParam accessors ---------------------------------------- -# The nested getters return the Param itself, so a caller edits it with its -# own replacement methods and hands it back: -# cs <- credibleSetParam(g); csCoverage(cs) <- 0.9; credibleSetParam(g) <- cs +# The nested getters return the Param itself, so a caller edits it with `$<-` +# and hands it back: +# cs <- g$credibleSetParam; cs$coverage <- 0.9; g$credibleSetParam <- cs #' @rdname GwasFineMappingParam setMethod("fineMappingMethods", "GwasFineMappingParam", function(x) { x@methods }) -#' @rdname GwasFineMappingParam -setReplaceMethod( - "fineMappingMethods", - "GwasFineMappingParam", - function(x, value) { - x@methods <- value - validObject(x) - x - } -) - #' @rdname GwasFineMappingParam setMethod("credibleSetParam", "GwasFineMappingParam", function(x) { x@credibleSetParam }) -#' @rdname GwasFineMappingParam -setReplaceMethod( - "credibleSetParam", - "GwasFineMappingParam", - function(x, value) { - x@credibleSetParam <- value - validObject(x) - x - } -) - #' @rdname GwasFineMappingParam setMethod("susieRssParam", "GwasFineMappingParam", function(x) x@susieRssParam) -#' @rdname GwasFineMappingParam -setReplaceMethod("susieRssParam", "GwasFineMappingParam", function(x, value) { - x@susieRssParam <- value - validObject(x) - x -}) - #' @rdname GwasFineMappingParam setMethod("panelFilterParam", "GwasFineMappingParam", function(x) { x@panelFilterParam }) -#' @rdname GwasFineMappingParam -setReplaceMethod( - "panelFilterParam", - "GwasFineMappingParam", - function(x, value) { - x@panelFilterParam <- value - validObject(x) - x - } -) - #' @rdname GwasFineMappingParam setMethod("initializeWithSusieInf", "GwasFineMappingParam", function(x) { x@initializeWithSusieInf }) -#' @rdname GwasFineMappingParam -setReplaceMethod( - "initializeWithSusieInf", - "GwasFineMappingParam", - function(x, value) { - x@initializeWithSusieInf <- value - validObject(x) - x - } -) - #' @rdname GwasFineMappingParam setMethod("fitRetention", "GwasFineMappingParam", function(x) x@fitRetention) -#' @rdname GwasFineMappingParam -setReplaceMethod("fitRetention", "GwasFineMappingParam", function(x, value) { - x@fitRetention <- value - validObject(x) - x -}) - #' @title Arguments For coloc's Bayes-Factor Scorer #' @description Options forwarded to \code{coloc::coloc.bf_bf}. The prior #' probabilities are \emph{not} settable here --- pecotmr derives them from @@ -1710,14 +2109,24 @@ ColocOptions <- function(overlap.min = NULL, trim_by_posterior = NULL, ...) { # Run coloc.bf_bf for an aligned pair, warning + NULL on failure. # @noRd #' @importFrom rlang try_fetch +# An LBF matrix with coloc's "null" column: log BF 0, the null against itself. +# Without one, coloc.bf_bf takes the LAST variant for the null and subtracts +# its LBF from the others, which is NaN when that LBF is -Inf -- as it is for +# an effect of a collapsed block fit that sits in another block. With one +# nothing is shifted, so a single block's scores are unchanged. +# @noRd +.colocWithNull <- function(lbf) { + cbind(lbf, null = 0) +} + .colocRunPair <- function(aligned, p12Used, q, gInfo, p1, p2, ColocOptions) { # Engine-call exception: coloc's whole interface is two blocks -- this and # ColocOptions -- so a colocWrapper.R would hold ~50 lines against this # file's 1600. The engine boundary is stated here instead of split out. callArgs <- c( list( - aligned$qtl, - aligned$gwas, + .colocWithNull(aligned$qtl), + .colocWithNull(aligned$gwas), p1 = p1, p2 = p2, p12 = p12Used diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 633b86df..f3fca1a3 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -7,10 +7,10 @@ #' multi-context data. Per-context residualized X / Y are #' 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{ldReference}). Must already have +#' \item \code{QtlSumStats} -- summary-statistic-only QTL data with an +#' LD reference per row (\code{ldReference}). Must already have #' been passed through \code{\link{summaryStatsQc}} (the -#' pipeline rejects inputs whose \code{qcInfo()} is empty). +#' pipeline rejects inputs whose \code{qcOptions()} is empty). #' Every analysis variant is available on this input, including #' \code{xqtlColoc}, which colocalizes the QTL studies against #' each other with no GWAS involved. @@ -27,11 +27,10 @@ #' @section QC contract: #' \itemize{ #' \item Individual-level QC (MAF / MAC / X-variance / per-sample -#' missingness, sample / variant restrictions) lives on the -#' \code{QtlDataset} constructor and is applied lazily inside -#' \code{genotypes()} / \code{residualizedGenotypes()}. -#' The pipeline does \emph{not} run a separate -#' individual-level QC pass. +#' missingness, sample / variant restrictions) is +#' \code{genotypeFilterParam}, applied to each block of genotypes +#' the pipeline extracts. A \code{QtlDataset} records no filter +#' of its own. #' \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 @@ -46,7 +45,7 @@ #' imputation, etc.) lives in #' \code{\link{summaryStatsQc}}. The pipeline rejects any #' \code{QtlSumStats} or \code{GwasSumStats} where -#' \code{length(qcInfo(x)) == 0L}. +#' \code{length(qcOptions(x)) == 0L}. #' } #' #' @section Analysis variants: @@ -56,44 +55,71 @@ #' \code{gwasSumStats}. Works for either data form -- the #' individual-level contexts, the summary-level QTL studies, or #' both together when a \code{MultiStudyQtlDataset} carries a -#' mixture. This is the only variant that honors -#' \code{focalTrait}. -#' \item \code{jointGwas} (default \code{FALSE}): run a non-focal -#' colocboost model that combines all QTL contexts/studies -#' with the supplied \code{gwasSumStats} studies. -#' \item \code{separateGwas} (default \code{FALSE}): run one focal -#' colocboost model per GWAS study, where the GWAS is the -#' focal outcome. +#' mixture. Non-focal unless \code{focalOutcome} names one of its +#' QTL outcomes. +#' \item \code{jointGwas} (default \code{FALSE}): run one non-focal +#' colocboost model (colocboost's disease-agnostic mode) that +#' combines all QTL contexts/studies with the supplied +#' \code{gwasSumStats} studies, however many there are. +#' \item \code{separateGwas} (default \code{FALSE}): run one colocboost +#' model per GWAS study, focal on that study (the +#' disease-prioritized mode), even when there is only one. #' } +#' The flags combine freely, as in colocboost's own pipeline. With one +#' GWAS study, \code{jointGwas} and \code{separateGwas} fit the same +#' outcomes, one non-focal and one focal on the GWAS. #' #' @param qtlData One of \code{QtlDataset}, \code{QtlSumStats}, or #' \code{MultiStudyQtlDataset}. #' @param gwasSumStats Optional \code{GwasSumStats} with the GWAS studies to -#' colocalize against. \code{NULL} to skip GWAS colocalization. -#' @param contexts Optional character vector of context names to restrict the -#' individual-level / QtlSumStats QTL analysis to. When \code{NULL} (default), -#' every context present is used. -#' @param traitId Optional character vector of trait identifiers to restrict the -#' analysis to. When supplied with an individual-level \code{QtlDataset} -#' input, \code{cisWindow} is required (passed to -#' \code{residualizedGenotypes} / \code{molecularTraits} for the -#' variant-window selection). +#' colocalize against. \code{NULL} to skip GWAS colocalization. Each study +#' is one outcome: the union of its rows that the QTL data overlap, so a +#' study split by chromosome or LD block contributes just the one or two +#' rows the QTL region reaches, and a study none of whose rows it reaches is +#' left out. QTL variants outside every loaded block of a study the QTL data +#' overlap are an error where the blocks' ranges were given +#' (\code{regionGiven}, see \code{\linkS4class{GwasSumStats}}), since they +#' lie in a block that was not loaded, and a warning for more than one in a +#' row past a range computed from the GWAS variants. Those rows must share +#' one LD reference, but it need not be the +#' QTL side's: every outcome's summary statistics are matched against their +#' own reference. When some references are genotype panels and others are +#' \code{LdMatrix} objects, the runs that combine them pass colocboost the +#' panels' LD as matrices, since colocboost takes LD matrices or reference +#' genotypes but not both. +#' @param contexts Optional character vector of context names to restrict +#' the individual-level / QtlSumStats QTL analysis to. When \code{NULL} +#' (default), every context present is used. A MultiStudyQtlDataset applies +#' it to every study: a context no study has is an error, and one only some +#' studies lack is skipped for those, with a warning. +#' @param traitId Optional character vector of trait identifiers to restrict +#' the analysis to. When supplied with an individual-level +#' \code{QtlDataset} input, \code{cisWindow} is required: each trait's +#' position \eqn{\pm} \code{cisWindow} is the variant window. In a +#' MultiStudyQtlDataset a study carrying none of them sits out; the run is +#' refused only when no study or summary-statistics row carries one. #' @param region Optional single-range \code{GRanges} describing the analysis -#' window. Mutually exclusive with \code{traitId} (see the \code{QtlDataset} -#' accessors). Individual-level input only: summary statistics carry no -#' genotypes to window, so the \code{QtlSumStats} method does not take it -#' --- matching \code{\link{fineMappingPipeline}} and -#' \code{\link{twasWeightsPipeline}}. -#' @param cisWindow Optional cis window in basepairs; required with -#' \code{traitId}, optional with \code{region}. Individual-level input -#' only, as for \code{region}. +#' window. Mutually exclusive with \code{traitId}. Individual-level input +#' only: a summary-statistics tuple +#' keeps the window it was built with (its \code{region}), so the +#' \code{QtlSumStats} method does not take one --- matching +#' \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. +#' @param cisWindow Optional cis window in basepairs. Individual-level +#' input: required with \code{traitId}, optional with \code{region}. +#' QtlSumStats input: each selected tuple is analysed over its +#' \code{traitPos} \eqn{\pm} \code{cisWindow}, within its \code{region}; +#' every selected tuple needs a \code{traitPos}. A MultiStudyQtlDataset +#' applies it to both kinds of study it holds. #' @param samples Optional character vector of sample IDs to restrict the #' analysis to; \code{NULL} (default) uses all samples. -#' @param focalTrait Optional trait name; when supplied and present in the -#' assembled outcome list, the colocboost xQTL-only run uses it as the focal -#' outcome. Only \code{xqtlColoc} reads it: \code{jointGwas} is -#' non-focal by construction and \code{separateGwas} always makes the -#' GWAS study focal. +#' @param focalOutcome The QTL outcome the \code{xqtlColoc} run treats as +#' focal (colocboost's \code{focal_outcome_idx}): a named character vector +#' with any of \code{study}, \code{context} and \code{trait} that +#' identifies exactly one QTL outcome, e.g. +#' \code{c(context = "brain", trait = "ENSG1")}. \code{NULL} (default) runs +#' it non-focal. It needs \code{xqtlColoc = TRUE}: the \code{jointGwas} run +#' is never focal, and each \code{separateGwas} run is focal on its own +#' GWAS study. #' @param xqtlColoc,jointGwas,separateGwas Logical flags selecting which #' colocboost variants to run. #' @param signalScreenParam Individual-level pre-filter (ports the legacy @@ -119,15 +145,27 @@ #' summary-statistic sides against the LD reference panel, built with #' \code{\link{PanelFilterParam}}: a variant whose panel genotypes fall #' 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}. +#' filter nothing. Individual-level genotypes are filtered by +#' \code{genotypeFilterParam} instead. +#' @param genotypeFilterParam Which individual-level variants and samples to +#' keep, built with \code{\link{GenotypeFilterParam}}: its +#' \code{keepSamples} narrows the dataset once, and its MAF, MAC, +#' variance, missingness, \code{keepVariants} and \code{keepIndel} +#' settings apply to each extracted block, as in +#' \code{\link{fineMappingPipeline}}. The default filters nothing. +#' \code{QtlDataset} and \code{MultiStudyQtlDataset} input only. +#' @param phenotypeFilterParam The run's phenotype QC, built with +#' \code{\link{PhenotypeFilterParam}}. colocboost takes missing phenotype +#' values as they are, so unset keeps them; \code{"drop"} or +#' \code{"impute"} applies that instead, and \code{outlierAction = +#' "drop"} removes outlier samples. \code{QtlDataset} and +#' \code{MultiStudyQtlDataset} input only. #' @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 #' out of each side and --- through \code{scaleResiduals} --- whether the -#' columns are scaled to unit variance. Previously absent, which left this -#' pipeline on the dataset's own settings with no per-call say, unlike +#' columns are scaled to unit variance, as in #' \code{\link{fineMappingPipeline}} and #' \code{\link{twasWeightsPipeline}}. \strong{Ignored} on #' \code{QtlSumStats} input, which has nothing to residualize. @@ -152,11 +190,15 @@ #' \code{separate_gwas} runs. Outcome-specific (uncolocalized) sets are #' included with \code{isColocalized = FALSE}. #' -#' Project it with \code{\link{colocPairs}} (also available as -#' \code{as.data.frame}), \code{\link{colocVariants}} or -#' \code{\link{colocBoostOutcomes}}; timings are on +#' Project it with \code{\link{colocPairs}}, \code{\link{colocVariants}} +#' or \code{\link{colocBoostOutcomes}}; timings are on #' \code{\link{computingTime}} and the region-wide marginal -#' probabilities on \code{\link{regionVcp}}. +#' probabilities on \code{\link{regionVcp}}. \code{\link{ldReference}} +#' returns the LD references the summary statistics were matched against, +#' each stored once, and the \code{ldReference} column of +#' \code{colocBoostOutcomes()} names the one each outcome used. Its +#' \code{seqinfo()} names the genome build the inputs name; inputs naming +#' different builds are refused. #' @name colocboostPipeline #' @importFrom methods is setGeneric setMethod #' @importFrom S4Vectors mcols @@ -208,6 +250,125 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { )) } +# focalOutcome's shape: NULL, or a named character vector of `study` / +# `context` / `trait` naming the xQTL-only run's focal QTL outcome, which only +# that run can have. Whether it names a real outcome is settled once the +# outcomes are built (.cbResolveFocal()). +# @noRd +.cbAssertFocalOutcome <- function(focalOutcome, xqtlColoc) { + if (is.null(focalOutcome)) { + return(invisible(NULL)) + } + runs <- str_c( + "The `jointGwas` run is never focal, and each `separateGwas` run is ", + "focal on its own GWAS study." + ) + if (!.cbFocalShapeOk(focalOutcome)) { + abort(c( + str_c( + "colocboostPipeline: `focalOutcome` must be NULL or a named ", + "character vector of `study`, `context` and/or `trait` naming ", + "one QTL outcome, e.g. ", + "c(context = \"brain\", trait = \"ENSG1\")." + ), + i = runs + )) + } + if (!isTRUE(xqtlColoc)) { + abort(c( + str_c( + "colocboostPipeline: `focalOutcome` names the xQTL-only run's ", + "focal outcome, but `xqtlColoc` is FALSE." + ), + i = runs + )) + } + invisible(NULL) +} + +# A named character vector whose names are distinct fields of a QTL outcome. +# @noRd +.cbFocalShapeOk <- function(x) { + if (!is.character(x) || length(x) == 0L || anyNA(x)) { + return(FALSE) + } + nm <- names(x) + !is.null(nm) && + !anyDuplicated(nm) && + all(is_in(nm, c("study", "context", "trait"))) +} + +# The QTL outcome the xQTL-only run is focal on, from `focalOutcome`; NULL for +# none. `qtlInfo` lists the QTL outcomes (.cbQtlOutcomeInfo()). +# @noRd +.cbResolveFocal <- function(focalOutcome, qtlInfo) { + if (is.null(focalOutcome)) { + return(NULL) + } + .cbFocalQtlName(focalOutcome, qtlInfo) +} + +# The one QTL outcome a focalOutcome vector identifies. +# @noRd +.cbFocalQtlName <- function(focal, qtlInfo) { + hit <- reduce( + names(focal), + .cbFocalField, + focal = focal, + qtlInfo = qtlInfo, + .init = rep(TRUE, nrow(qtlInfo)) + ) + if (sum(hit) == 1L) { + return(qtlInfo$name[hit]) + } + .cbAbortFocalQtl(focal, qtlInfo, hit) +} + +# @noRd +.cbFocalField <- function(hit, field, focal, qtlInfo) { + hit & is_in(qtlInfo[[field]], focal[[field]]) +} + +# A focalOutcome vector that names no QTL outcome, or several. +# @noRd +.cbAbortFocalQtl <- function(focal, qtlInfo, hit) { + asked <- str_flatten(str_c(names(focal), " = '", focal, "'"), ", ") + if (any(hit)) { + abort(c( + glue( + "colocboostPipeline: focalOutcome ({asked}) matches ", + "{sum(hit)} QTL outcomes: ", + "{.cbDescribeOutcomes(filter(qtlInfo, hit))}." + ), + i = "Add `study`, `context` or `trait` until it names one." + )) + } + abort(c( + glue( + "colocboostPipeline: focalOutcome ({asked}) matches no QTL ", + "outcome." + ), + i = glue("The QTL outcomes are: {.cbDescribeOutcomes(qtlInfo)}.") + )) +} + +# "study / context / trait" for up to ten outcomes, "-" for a part one lacks. +# @noRd +.cbDescribeOutcomes <- function(info) { + if (nrow(info) == 0L) { + return("none") + } + shown <- slice(info, seq_len(min(10L, nrow(info)))) + listed <- str_c( + coalesce(shown$study, "-"), + coalesce(shown$context, "-"), + coalesce(shown$trait, "-"), + sep = " / " + ) + more <- if (nrow(info) > 10L) str_c(", and ", nrow(info) - 10L, " more") + str_c(str_flatten(listed, "; "), more %||% "") +} + # The data slots the pipeline builds from its inputs. They are real # colocboost formals, so the union check would accept them -- but the # pipeline supplies them, so a value given here would be overwritten. @@ -256,16 +417,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # Reject SumStats objects that have not been passed through -# summaryStatsQc(). Both QtlSumStats and GwasSumStats expose qcInfo(); +# summaryStatsQc(). Both QtlSumStats and GwasSumStats expose qcOptions(); # an empty list (the constructor default) signals "no QC run". .cbRequireSumStatsQc <- function(x, what) { if (is.null(x)) { return(invisible(NULL)) } - if (length(qcInfo(x)) == 0L) { + if (length(qcOptions(x)) == 0L) { msg <- glue( "{what} must be passed through summaryStatsQc() before ", - "reaching colocboostPipeline (qcInfo() returned an empty ", + "reaching colocboostPipeline (qcOptions() returned an empty ", "list). Call summaryStatsQc(x, ...) and pass the result." ) abort(msg) @@ -308,11 +469,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { cisWindow = NULL, samples = NULL, pipCutoffToSkip = 0, - residualizationParam = ResidualizationParam() + residualizationParam = ResidualizationParam(), + genotypeFilter, + phenotypeFilter = .qtlKeepAllPhenotypes() ) { contexts <- .cbResolveBundleContexts(qd, contexts) p <- list( qd = qd, + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter, traitId = traitId, region = region, cisWindow = cisWindow, @@ -328,10 +493,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { YperCtx <- set_names(map(built, "Y"), map_chr(built, "ctx")) dedup <- .cbDedupX(XperCtx) split <- .cbSplitY(YperCtx, dedup$xMatch) + # An individual-level outcome's LD comes from its own genotypes, so it has + # no LD-reference entry to name. outcomeInfo <- mutate( split$outcomeInfo, study = studyName(qd), - dataForm = "individual" + dataForm = "individual", + ldReference = NA_character_ ) list( X = dedup$uniqueX, @@ -364,6 +532,71 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { contexts } +# A `trait` no selected context carries is refused, as fineMappingPipeline and +# twasWeightsPipeline refuse it, rather than every context being skipped into +# an empty result. +# @noRd +.cbAssertTraitsSelected <- function(qd, contexts, traitId) { + ctxs <- .cbResolveBundleContexts(qd, contexts) + carried <- map_lgl(ctxs, .cbContextCarries, qd = qd, traitId = traitId) + if (length(traitId) > 0L && !any(carried)) { + abort("colocboostPipeline(QtlDataset): no traits selected.") + } + invisible(NULL) +} + +# The QtlSumStats form: a contexts / trait selection that matches no row. +# @noRd +.cbAssertQssRowsSelected <- function(ss, contexts, traitId) { + if (nrow(ss) > 0L && !any(.cbQtlRowsSelected(ss, contexts, traitId))) { + abort(glue( + "colocboostPipeline(QtlSumStats): no entries matched the ", + "supplied contexts / traitId filters." + )) + } + invisible(NULL) +} + +# The multi-study form: refused only when no embedded dataset's contexts and +# no sumstat row carry a requested trait. A study that lacks it sits out, as +# it does in fineMappingPipeline and twasWeightsPipeline. +# @noRd +.cbMsAssertTraitsSelected <- function(msqd, contexts, traitId) { + if (length(traitId) == 0L) { + return(invisible(NULL)) + } + inData <- map_lgl( + as.list(msqd), + .cbDatasetCarries, + contexts = contexts, + traitId = traitId + ) + ss <- sumStats(msqd) + inSumStats <- !is.null(ss) && + nrow(ss) > 0L && + any(.cbQtlRowsSelected(ss, contexts, traitId)) + if (!any(inData) && !inSumStats) { + abort("colocboostPipeline(MultiStudyQtlDataset): no traits selected.") + } + invisible(NULL) +} + +# Whether any of a dataset's selected contexts carries a requested trait; +# contexts it lacks are left out (a study need not carry every context). +# @noRd +.cbDatasetCarries <- function(qd, contexts, traitId) { + ctxs <- intersect(contexts %||% contexts(qd), contexts(qd)) + any(map_lgl(ctxs, .cbContextCarries, qd = qd, traitId = traitId)) +} + +# Whether one context carries any requested trait (every context does when no +# trait was requested). +# @noRd +.cbContextCarries <- function(ctx, qd, traitId) { + length(traitId) == 0L || + any(is_in(traitId, rownames(.qtlContextSe(qd, context = ctx)))) +} + # Residualized (X, Y) for one context (sample-aligned + signal-screened), or # NULL when the context should be skipped. # @noRd @@ -373,7 +606,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ctx, p$traitId, p$region, - p$residualizationParam + p$residualizationParam, + p$phenotypeFilter ) if (is.null(rawY) || ncol(rawY) == 0L) { return(NULL) @@ -385,11 +619,19 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { p$region, p$cisWindow, p$samples, - p$residualizationParam + p$residualizationParam, + p$genotypeFilter ) if (is.null(rawX) || ncol(rawX) == 0L) { return(NULL) } + .cbAlignContextXY(ctx, rawX, rawY, p$pipCutoffToSkip) +} + +# One context's X and Y on the samples they share, Y signal-screened; NULL, +# with a message, when they share none. +# @noRd +.cbAlignContextXY <- function(ctx, rawX, rawY, pipCutoffToSkip) { # Canonicalize variant colnames (chr-prefix + separator, allele order # preserved; rsIDs passed through) so colocboost's name-based matching # aligns them with the sumstat / LD ids and across studies. A genuine @@ -406,18 +648,25 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { return(NULL) } X <- named[common, , drop = FALSE] - Y <- .cbApplyScreen( - X, - rawY[common, , drop = FALSE], - ctx, - p$pipCutoffToSkip - ) + Y <- .cbApplyScreen(X, rawY[common, , drop = FALSE], ctx, pipCutoffToSkip) if (is.null(Y)) { return(NULL) } list(ctx = ctx, X = X, Y = Y) } +# colocboost's phenotype QC: colocboost takes missing phenotypes as they are, +# so an unset naAction keeps them, and every choice is available. +# @noRd +.cbResolvePhenotypeFilter <- function(phenotypeFilterParam) { + .qtlResolvePhenotypeFilter( + phenotypeFilterParam, + naDefault = "keep", + naAllowed = c("keep", "drop", "impute"), + caller = "colocboostPipeline" + ) +} + # Residualized phenotypes for one context (message + NULL on failure). # @noRd .cbResidualizedY <- function( @@ -425,16 +674,18 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ctx, traitId, region, - residualizationParam = ResidualizationParam() + residualizationParam = ResidualizationParam(), + phenotypeFilter = .qtlKeepAllPhenotypes() ) { try_fetch( - residualizedPhenotypes( + .qtlResidualizedPhenotypes( qd, contexts = ctx, traitId = traitId, - region = region, + window = region, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam - ), + )[[ctx]], error = function(cnd) { msg <- glue( "colocboostPipeline: skipping context '{ctx}' ", @@ -455,16 +706,16 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region, cisWindow, samples, - residualizationParam = ResidualizationParam() + residualizationParam = ResidualizationParam(), + genotypeFilter ) { try_fetch( - residualizedGenotypes( + .qtlResidualizedGenotypes( qd, contexts = ctx, - traitId = traitId, - region = region, - cisWindow = cisWindow, + window = .qtlResolveVariantRegion(qd, traitId, region, cisWindow), samples = samples, + filter = genotypeFilter, residualizationParam = residualizationParam ), error = function(cnd) { @@ -658,11 +909,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { keptIds <- attr(ld, "keptVariantIds") kept <- filter(df, is_in(variantIds, keptIds)) ss <- .cbSumstatFrame(kept, keptIds, nCase, nControl, varY) + # The reference rides with the pair, so the result can record the one + # each outcome was matched against. list( sumstat = ss, LD = `attr<-`(ld, "keptVariantIds", NULL), variantIds = keptIds, - isFactor = .ldIsGenotypeRef(ldReference) + isFactor = .ldIsGenotypeRef(ldReference), + ldReference = ldReference ) } @@ -730,18 +984,34 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } # Build the colocboost sumstat / LD bundle from a QtlSumStats and an -# optional contexts / traitId filter. Returns a list keyed by sumstat -# study label, where each entry has (sumstat, LD). +# optional contexts / traitId filter, with `cisWindow` laid on the tuples it +# keeps. Returns a list keyed by sumstat study label, where each entry has +# (sumstat, LD). .cbQtlSumStatsBundle <- function( ss, contexts = NULL, traitId = NULL, - cutoffs = NULL + cutoffs = NULL, + cisWindow = NULL ) { if (is.null(ss) || nrow(ss) == 0L) { return(list()) } - ldReference <- ldReference(ss) + rows <- which(.cbQtlRowsSelected(ss, contexts, traitId)) + if (length(rows) == 0L) { + return(list()) + } + ss <- .qssApplyCisWindow(ss, cisWindow, "colocboostPipeline", rows) + compact(set_names( + map(rows, .cbQtlEntryPair, ss = ss, cutoffs = cutoffs), + map_chr(rows, .cbQtlEntryLabel, ss = ss) + )) +} + +# The rows of `ss` colocboost's selection keeps: `contexts` and `traitId` are +# plain vectors here, and an empty one keeps everything. +# @noRd +.cbQtlRowsSelected <- function(ss, contexts, traitId) { byContext <- if (!is.null(contexts) && length(contexts) > 0L) { is_in(as.character(ss$context), contexts) } else { @@ -752,22 +1022,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } else { TRUE } - keepRow <- byContext & byTrait - if (!any(keepRow)) { - return(list()) - } - rows <- which(keepRow) - - compact(set_names( - map( - rows, - .cbQtlEntryPair, - ss = ss, - ldReference = ldReference, - cutoffs = cutoffs - ), - map_chr(rows, .cbQtlEntryLabel, ss = ss) - )) + byContext & byTrait } # @noRd @@ -780,21 +1035,33 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) } -# One QTL entry's (sumstat, LD) pair, or NULL when it has no panel overlap. +# One QTL entry's (sumstat, LD) pair, against the entry's own LD reference, +# or NULL when it has no panel overlap. It carries the tuple it came from, +# which a focalOutcome vector is matched against, and the tuple's span, which +# decides the GWAS rows a study contributes (.cbQtlWindow()). # @noRd -.cbQtlEntryPair <- function(i, ss, ldReference, cutoffs) { - .cbSumstatPair( - df = as.data.frame( +.cbQtlEntryPair <- function(i, ss, cutoffs) { + tuple <- list( + study = as.character(ss$study)[[i]], + context = as.character(ss$context)[[i]], + trait = as.character(ss$trait)[[i]] + ) + pair <- .cbSumstatPair( + df = .sumStatsDf( ss, - studyName = as.character(ss$study)[[i]], - context = as.character(ss$context)[[i]], - trait = as.character(ss$trait)[[i]], + studyName = tuple$study, + context = tuple$context, + trait = tuple$trait, require = "Z" ), - ldReference = ldReference, + ldReference = .rowLdRef(ss, i), varY = .cbTupleValue(ss, "varY", i), cutoffs = cutoffs ) + if (is.null(pair)) { + return(NULL) + } + list_assign(pair, !!!tuple, span = range(ss[[i]])) } # A tuple column's value for row `i`, or NA when the collection lacks it. @@ -808,62 +1075,88 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { S4Vectors::mcols(collection, use.names = FALSE)[[column]][[i]] } -# Same as .cbQtlSumStatsBundle for a GwasSumStats collection, keyed by -# study label. -.cbGwasSumStatsBundle <- function(gws, cutoffs = NULL) { +# Same as .cbQtlSumStatsBundle for a GwasSumStats collection: one pair per +# STUDY, keyed by study name. A study split by chromosome or LD block owns +# several rows, but it is one trait, so it reaches colocboost as one outcome +# -- the union of the rows that overlap `window`, where the QTL data sit +# (.cbQtlWindow()); its other rows are not read. `window = NULL` takes every +# row. +.cbGwasSumStatsBundle <- function(gws, window = NULL, cutoffs = NULL) { if (is.null(gws) || nrow(gws) == 0L) { return(list()) } - ldReference <- ldReference(gws) - compact(set_names( - map( - seq_len(nrow(gws)), - .cbGwasEntryPair, - gws = gws, - ldReference = ldReference, - cutoffs = cutoffs - ), - as.character(gws$study) + index <- .rowSpans(gws) + hit <- if (is.null(window)) { + rep(TRUE, length(index$rows)) + } else { + .overlapsOnShared(index$spans, window) + } + rows <- unique(index$rows[hit]) + studies <- as.character(gws$study) + .cbInformGwasLeftOut(setdiff(unique(studies), studies[rows])) + compact(imap( + split(rows, factor(studies[rows], levels = unique(studies[rows]))), + .cbGwasStudyPair, + gws = gws, + cutoffs = cutoffs )) } -# One GWAS entry's (sumstat, LD) pair, or NULL when it has no panel overlap. # @noRd -.cbGwasEntryPair <- function(i, gws, ldReference, cutoffs) { - .cbSumstatPair( - df = as.data.frame( +.cbInformGwasLeftOut <- function(studies) { + if (length(studies) == 0L) { + return(invisible(NULL)) + } + inform(glue( + "colocboostPipeline: leaving out GWAS ", + "{str_flatten(studies, ', ')}: no row overlaps the QTL data." + )) +} + +# One GWAS study's (sumstat, LD) pair over `rows`, its rows the QTL data +# overlap, stitched into one outcome; NULL when it has no panel overlap. The +# rows' statistics are read against one LD matrix, so they must share an LD +# reference. The study-level columns (varY, nCase, nControl) repeat on every +# row, so the first row's stand for the study. +# @noRd +.cbGwasStudyPair <- function(rows, study, gws, cutoffs) { + pair <- .cbSumstatPair( + df = .entryToSumstatDf( + .ssStitchElements(gws, rows), + require = "Z", + derive = "none", + keepChrPrefix = TRUE, + label = glue("GwasSumStats[{study}]") + ), + ldReference = .rowsSharedLdRef( gws, - studyName = as.character(gws$study)[[i]], - require = "Z" + rows, + glue( + "colocboostPipeline: the rows of GWAS study '{study}' the ", + "QTL data overlap" + ) ), - ldReference = ldReference, - varY = .cbTupleValue(gws, "varY", i), - nCase = .cbTupleValue(gws, "nCase", i), - nControl = .cbTupleValue(gws, "nControl", i), + varY = .cbTupleValue(gws, "varY", rows[[1L]]), + nCase = .cbTupleValue(gws, "nCase", rows[[1L]]), + nControl = .cbTupleValue(gws, "nControl", rows[[1L]]), cutoffs = cutoffs ) -} - -# Check two LD sketches for the reference-panel compatibility contract. Thin -# 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). -.cbRequireMatchingLdRefs <- function(qtlLd, gwasLd) { - .requireMatchingLdRefs( - qtlLd, - gwasLd, - pipelineName = "colocboostPipeline", - nullPolicy = "lenient" - ) + if (is.null(pair)) { + return(NULL) + } + list_assign(pair, study = study) } # 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, 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. +# list holds LD matrices ("LD") or factors of them ("X_ref"). +# +# The QTL and GWAS sides each read their own LD reference, so a run can mix a +# genotype panel's factors with an LdMatrix's matrices. colocboost takes LD or +# X_ref but not both, so such a run gets every factor as its LD matrix -- the +# matrix colocboost would compute from it anyway once a panel has at least as +# many samples as variants. .cbMergeSumstatBundles <- function(bundles) { if (length(bundles) == 0L) { return(list( @@ -873,12 +1166,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ldArg = "LD" )) } - kinds <- unique(map_lgl(bundles, .cbPairIsFactor)) - if (length(kinds) > 1L) { - abort( - "colocboost inputs mix LD matrices and genotype factors.", - .internal = TRUE - ) + isFactor <- map_lgl(bundles, .cbPairIsFactor) + if (any(isFactor) && !all(isFactor)) { + bundles <- map(bundles, .cbPairAsLdMatrix) } # Same shape as .cbDedupX: every bundle resolves to the first bundle # carrying an identical LD matrix, so the unique set and the back-mapping @@ -893,7 +1183,22 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { sumstat = seq_along(bundles), LD = match(firstIdx, keepIdx) ), - ldArg = if (kinds) "X_ref" else "LD" + ldArg = if (all(map_lgl(bundles, .cbPairIsFactor))) "X_ref" else "LD" + ) +} + +# A (sumstat, LD) pair with its LD held as the matrix. A factor F of a +# genotype reference gives crossprod(F) / (nrow(F) - 1), which is that +# reference's LD over the same variants (see .ldFactorFromRef()). +# @noRd +.cbPairAsLdMatrix <- function(p) { + if (!.cbPairIsFactor(p)) { + return(p) + } + list_assign( + p, + LD = crossprod(p$LD) / (nrow(p$LD) - 1L), + isFactor = FALSE ) } @@ -939,14 +1244,14 @@ 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. +# has no row for it, with no indication of why. Say so. # @noRd .cbWarnNoData <- function(flag, needed) { msg <- glue( "colocboostPipeline: {flag} = TRUE was requested, but there is no ", "{needed} to run it on. Skipping it -- the returned ", "ColocBoostResult will hold no confidence sets from this analysis ", - "and its computingTime() entry will be NULL." + "and its computingTime() will have no row for it." ) warn(msg) } @@ -955,9 +1260,11 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # 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. +# uses it, so that a GWAS study never becomes an xQTL-only outcome. `focal` +# names the xQTL-only run's focal outcome (.cbResolveFocal()); the joint run +# is never focal, and each separate run is focal on its own GWAS. The result +# is keyed by the result slot each run fills; compact() drops what did not +# run. # @noRd .cbDispatchRuns <- function( individualBundle, @@ -965,7 +1272,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { qtlSumstatBundle, run, hasInd, - focalTrait, + focal, methodArgs, gwasRunBundles = list() ) { @@ -975,7 +1282,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, qtlSumstatBundle, hasInd, - focalTrait, + focal, methodArgs ) }, @@ -1081,6 +1388,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Run the requested colocboost analyses over the prepared bundles and fold # them into a ColocBoostResult (an empty one when no QTL input remains). +# `focal` names the xQTL-only run's focal outcome; `resultInfo` carries the +# outcome table and LD references the result records (.cbPrepareInputs()). # @noRd .cbRunVariants <- function( individualBundle, @@ -1088,9 +1397,9 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { xqtlColoc, jointGwas, separateGwas, - focalTrait, + focal, methodArgs, - qtlLdReference = NULL, + resultInfo = list(outcomeInfo = .cbEmptyOutcomeInfo(), ldRefs = list()), qtlSumstatBundle = NULL, gwasRunBundles = list() ) { @@ -1120,15 +1429,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { qtlSumstatBundle, run, hasInd, - focalTrait, + focal, methodArgs, gwasRunBundles = gwasRunBundles ) - results <- .cbMergeRuns(.cbEmptyResult(), runs) .cbToResultObject( - results, - .cbOutcomeInfo(individualBundle, sumstatBundle, hasInd), - qtlLdReference + .cbMergeRuns(.cbEmptyResult(), runs), + resultInfo$outcomeInfo, + resultInfo$ldRefs ) } @@ -1178,7 +1486,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # key: without it the separate-GWAS sets would be indistinguishable from each # other once flattened. # @noRd -.cbToResultObject <- function(results, outcomeInfo, ldReference = NULL) { +.cbToResultObject <- function(results, outcomeInfo, ldReference = list()) { sep <- results$separate_gwas sepRuns <- if (is.null(sep) || length(sep) == 0L) { list() @@ -1239,18 +1547,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { individualBundle, sumstatBundle, hasInd, - focalTrait, + focal, methodArgs ) { traits <- c( if (hasInd) individualBundle$outcomeNames else character(), names(sumstatBundle$sumstat) ) - focalIdx <- if (!is.null(focalTrait) && is_in(focalTrait, traits)) { - which(traits == focalTrait) - } else { - NULL - } + focalIdx <- .cbFocalIdx(focal, traits) nCtx <- if (hasInd) length(individualBundle$Y) else 0L nSs <- length(sumstatBundle$sumstat) .cbAnnounceXqtl(nCtx, nSs) @@ -1288,22 +1592,22 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # # Outcome names reach colocboost as bare labels; this is what lets a # ColocBoostResult answer "which contexts colocalized" instead of handing the -# caller a string to parse. Sumstat outcomes are keyed by study name and carry -# no context or trait of their own, which is recorded as NA rather than -# invented. +# caller a string to parse. `ldKeys` names, per sumstat outcome, the result's +# LD-reference entry it was matched against (.cbResultLdRefs()), and +# `sumstatInfo` (.cbPairsInfo()) the tuple each sumstat outcome came from. # @noRd -.cbOutcomeInfo <- function(individualBundle, sumstatBundle, hasInd) { +.cbOutcomeInfo <- function( + individualBundle, + sumstatBundle, + hasInd, + ldKeys = character(0), + sumstatInfo = NULL +) { ssNames <- names(sumstatBundle$sumstat) parts <- compact(list( if (isTRUE(hasInd)) individualBundle$outcomeInfo, if (length(ssNames) > 0L) { - tibble( - name = ssNames, - context = NA_character_, - trait = NA_character_, - study = ssNames, - dataForm = "sumstats" - ) + .cbSumstatOutcomeInfo(ssNames, ldKeys, sumstatInfo) } )) if (length(parts) == 0L) { @@ -1312,6 +1616,37 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { bind_rows(parts) } +# The summary-statistic outcomes' rows. A QTL tuple records its study, +# context and trait; a GWAS study has no context or trait of its own, which +# is recorded as NA rather than invented. Without `sumstatInfo` each outcome +# stands as its own study. +# @noRd +#' @importFrom dplyr coalesce +.cbSumstatOutcomeInfo <- function(ssNames, ldKeys, sumstatInfo) { + info <- sumstatInfo %||% .cbPairsInfo(set_names(list(), character(0))) + hit <- match(ssNames, info$name) + tibble( + name = ssNames, + context = info$context[hit], + trait = info$trait[hit], + study = coalesce(info$study[hit], ssNames), + dataForm = "sumstats", + ldReference = unname(ldKeys[ssNames]) + ) +} + +# The (name, study, context, trait) of each summary-statistic pair, as the +# pair records them: a QTL tuple's three, a GWAS study's study alone. +# @noRd +.cbPairsInfo <- function(pairs) { + tibble( + name = names(pairs) %||% character(0), + study = map_chr(unname(pairs), "study", .default = NA_character_), + context = map_chr(unname(pairs), "context", .default = NA_character_), + trait = map_chr(unname(pairs), "trait", .default = NA_character_) + ) +} + # @noRd .cbEmptyOutcomeInfo <- function() { tibble( @@ -1319,11 +1654,14 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { context = character(0), trait = character(0), study = character(0), - dataForm = character(0) + dataForm = character(0), + ldReference = character(0) ) } -# Joint (non-focal) QTL + GWAS run -> list(result, time). +# Joint QTL + GWAS run -> list(result, time). Non-focal (colocboost's +# disease-agnostic mode) however many GWAS studies it holds: a GWAS-focal fit +# is a separate run. # @noRd .cbRunJointGwas <- function( individualBundle, @@ -1343,12 +1681,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # outcome that is not one of the GWAS studies, whether it arrived as # individual-level data or as summary statistics. nGwas <- length(intersect(ssNames, gwasNames)) - nContexts <- length(traits) - nGwas - msg <- glue( + inform(glue( "====== Performing non-focal GWAS-xQTL ColocBoost on ", - "{nContexts} contexts and {nGwas} GWAS. =====" - ) - inform(msg) + "{length(traits) - nGwas} contexts and {nGwas} GWAS. =====" + )) args <- c( list( X = if (hasInd) individualBundle$X else NULL, @@ -1370,6 +1706,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { list(result = run$result, time = run$time) } +# The position of outcome `focal` among `traits`, the form colocboost's +# focal_outcome_idx takes; NULL when there is no focal outcome or the run +# does not hold it. +# @noRd +.cbFocalIdx <- function(focal, traits) { + idx <- if (is.null(focal)) NA_integer_ else match(focal, traits) + if (is.na(idx)) NULL else idx +} + # Separate (focal) per-GWAS runs -> list(result, time) with per-study timing. # @noRd .cbRunSeparateGwas <- function( @@ -1517,7 +1862,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { sumstat = ss, LD = ld, variantIds = canonical[ib], - isFactor = isFactor + isFactor = isFactor, + ldReference = p$ldReference ) } @@ -1601,9 +1947,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { xqtlColoc, jointGwas, separateGwas, - focalTrait, + focalOutcome, methodArgs, - qtlLdReference = NULL, alleleFlip = TRUE, cutoffs = NULL ) { @@ -1611,35 +1956,161 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { inform("colocboostPipeline: no analysis flag is TRUE; nothing to do.") return(.cbEmptyResultObject()) } - combinedPairs <- .cbAppendGwasPairs( + inputs <- .cbPrepareInputs( + individualBundle, qtlPairs, gwasSumStats, - qtlLdReference, - cutoffs = cutoffs - ) - harmonized <- .cbMaybeHarmonize( - individualBundle, - combinedPairs, - alleleFlip + focalOutcome, + alleleFlip, + cutoffs ) - sumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs) - qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) - qtlSumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]) - gwasRunBundles <- .cbGwasRunBundles(harmonized$pairs, qtlKeys) .cbRunVariants( - harmonized$individualBundle, - sumstatBundle, + inputs$individualBundle, + inputs$sumstatBundle, xqtlColoc, jointGwas, separateGwas, - focalTrait, + inputs$focal, methodArgs, - qtlLdReference = qtlLdReference, - qtlSumstatBundle = qtlSumstatBundle, - gwasRunBundles = gwasRunBundles + resultInfo = inputs$resultInfo, + qtlSumstatBundle = inputs$qtlSumstatBundle, + gwasRunBundles = inputs$gwasRunBundles + ) +} + +# Everything the runs read, from the QTL side and gwasSumStats: each +# outcome's (sumstat, LD) pair -- a GWAS study once, over its rows the QTL +# data overlap -- allele-harmonized when asked; the bundles each run takes; +# the xQTL-only run's focal outcome; and the outcome table and LD references +# the result records. The tuples and keys are read before harmonization, +# which keeps every pair's name. +# @noRd +.cbPrepareInputs <- function( + individualBundle, + qtlPairs, + gwasSumStats, + focalOutcome, + alleleFlip, + cutoffs +) { + pairs <- .cbAppendGwasPairs( + qtlPairs, + gwasSumStats, + window = .cbQtlWindow(individualBundle, qtlPairs), + cutoffs = cutoffs, + qtlVariants = .cbQtlVariants(individualBundle, qtlPairs) + ) + harmonized <- .cbMaybeHarmonize(individualBundle, pairs, alleleFlip) + sumstatBundle <- .cbMergeSumstatBundles(harmonized$pairs) + qtlKeys <- intersect(names(harmonized$pairs), names(qtlPairs)) + ldRefs <- .cbResultLdRefs(harmonized$pairs) + list( + individualBundle = harmonized$individualBundle, + sumstatBundle = sumstatBundle, + qtlSumstatBundle = .cbMergeSumstatBundles(harmonized$pairs[qtlKeys]), + gwasRunBundles = .cbGwasRunBundles(harmonized$pairs, qtlKeys), + focal = .cbResolveFocal( + focalOutcome, + .cbQtlOutcomeInfo(individualBundle, qtlPairs) + ), + resultInfo = list( + outcomeInfo = .cbOutcomeInfo( + harmonized$individualBundle, + sumstatBundle, + !is.null(harmonized$individualBundle), + ldRefs$keys, + .cbPairsInfo(pairs) + ), + ldRefs = ldRefs$refs + ) + ) +} + +# Where the QTL data sit, one span per chromosome: the GWAS rows a study +# contributes are those overlapping it. Individual-level +# variants are placed by their ids, which the panel normalizes to chrom:pos +# form (an id that does not parse, such as an rsID, places nothing), and +# summary-level ones by their tuple's range. NULL when nothing is placed, +# which leaves every GWAS row in. +# @noRd +.cbQtlWindow <- function(individualBundle, qtlPairs) { + ids <- unique(list_c( + map(individualBundle$X, colnames), + ptype = character() + )) + parsed <- parseVariantId(ids) + ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) + placed <- exec( + c, + GenomicRanges::GRanges( + parsed$chrom[ok], + IRanges::IRanges(parsed$pos[ok], width = 1L) + ), + !!!unname(map(compact(map(qtlPairs, "span")), .locusRanges)) + ) + if (length(placed) == 0L) { + return(NULL) + } + range(placed) +} + +# The QTL variants a run reads, placed by their ids, each position once: the +# individual-level ones and those each summary-statistic pair kept. NULL when +# none places (an rsID places nothing). +# @noRd +.cbQtlVariants <- function(individualBundle, qtlPairs) { + ids <- unique(c( + list_c(map(individualBundle$X, colnames), ptype = character()), + list_c(map(unname(qtlPairs), "variantIds"), ptype = character()) + )) + parsed <- parseVariantId(ids) + ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) + if (!any(ok)) { + return(NULL) + } + unique(GenomicRanges::GRanges( + parsed$chrom[ok], + IRanges::IRanges(parsed$pos[ok], width = 1L) + )) +} + +# colocboost reads every QTL outcome together, so the QTL data are one +# region, checked against the LD blocks of the GWAS studies they overlap +# (.checkGwasBlockReach()). +# @noRd +.cbCheckBlockReach <- function(qtlVariants, gwasSumStats) { + if (is.null(qtlVariants)) { + return(invisible(NULL)) + } + .checkGwasBlockReach( + list(`the QTL data` = qtlVariants), + gwasSumStats, + "colocboostPipeline", + "the QTL data" ) } +# The QTL outcomes a focalOutcome vector is matched against: the +# individual-level ones with the (study, context, trait) they were built +# from, then each QTL summary-statistic tuple. +# @noRd +.cbQtlOutcomeInfo <- function(individualBundle, qtlPairs) { + ind <- individualBundle$outcomeInfo %||% .cbEmptyOutcomeInfo() + bind_rows( + select(ind, all_of(c("name", "study", "context", "trait"))), + .cbPairsInfo(qtlPairs) + ) +} + +# The LD references a result records -- each distinct one the summary +# statistics were matched against, once -- and each summary-statistic +# outcome's key into them, read off the pairs that carry them. +# @noRd +.cbResultLdRefs <- function(pairs) { + dict <- .ldRefDict(map(unname(pairs), "ldReference")) + list(refs = dict$refs, keys = set_names(dict$keys, names(pairs))) +} + # 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 @@ -1656,24 +2127,29 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) } -# 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.) +# Append the GWAS sumstat pairs -- one per study, over its rows that overlap +# `window` (.cbGwasSumStatsBundle()) -- to the QTL pairs, QC-gating +# gwasSumStats and make.unique-ing colliding labels. The GWAS side's LD comes +# from its own reference, which need not be the QTL side's: each pair carries +# the LD it was matched against. # @noRd .cbAppendGwasPairs <- function( qtlPairs, gwasSumStats, - qtlLdReference, - cutoffs = NULL + window = NULL, + cutoffs = NULL, + qtlVariants = NULL ) { if (is.null(gwasSumStats)) { return(qtlPairs) } .cbRequireSumStatsQc(gwasSumStats, "gwasSumStats") - if (!is.null(qtlLdReference)) { - .cbRequireMatchingLdRefs(qtlLdReference, ldReference(gwasSumStats)) - } - gwasPairs <- .cbGwasSumStatsBundle(gwasSumStats, cutoffs = cutoffs) + .cbCheckBlockReach(qtlVariants, gwasSumStats) + gwasPairs <- .cbGwasSumStatsBundle( + gwasSumStats, + window = window, + cutoffs = cutoffs + ) if (length(gwasPairs) == 0L) { return(qtlPairs) } @@ -1703,7 +2179,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { traitId, region, cisWindow, - focalTrait, + focalOutcome, xqtlColoc, jointGwas, separateGwas, @@ -1712,18 +2188,23 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { signalScreenParam, alleleFlip, methodArgs, + genotypeFilterParam, + phenotypeFilterParam, residualizationParam ) { screenSpec <- .screenResolve(signalScreenParam) + genotypeFilter <- .qtlResolveFilter(genotypeFilterParam) indBundle <- .cbIndividualBundle( - qtlData, + .qtlRestrictSamples(qtlData, genotypeFilter$keepSamples), contexts = contexts, traitId = traitId, region = region, cisWindow = cisWindow, samples = samples, pipCutoffToSkip = screenSpec, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, + phenotypeFilter = .cbResolvePhenotypeFilter(phenotypeFilterParam) ) .cbDriver( indBundle, @@ -1732,7 +2213,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { xqtlColoc, jointGwas, separateGwas, - focalTrait, + focalOutcome, methodArgs, alleleFlip = alleleFlip, # The QTL side is individual-level here, but the GWAS side may still @@ -1742,6 +2223,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { } +# The genome build colocboostPipeline()'s inputs share; NA when none names +# one, an error when two disagree. +# @noRd +.cbBuild <- function(...) { + .inputsBuild(list(...), "colocboostPipeline") +} + #' @rdname colocboostPipeline #' @export setMethod( @@ -1754,7 +2242,7 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - focalTrait = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -1762,23 +2250,24 @@ setMethod( panelFilterParam = PanelFilterParam(), signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, + genotypeFilterParam = GenotypeFilterParam(), + phenotypeFilterParam = PhenotypeFilterParam(), 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 - # .assertMethodOptions already accepts; anything else must be built. methodArgs = ColocboostOptions() ) { .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) - .cbQtlDatasetDrive( + .cbAssertFocalOutcome(focalOutcome, xqtlColoc) + .cbAssertTraitsSelected(qtlData, contexts, traitId) + build <- .cbBuild(qtlData, gwasSumStats, region) + res <- .cbQtlDatasetDrive( qtlData = qtlData, gwasSumStats = gwasSumStats, contexts = contexts, traitId = traitId, region = region, cisWindow = cisWindow, - focalTrait = focalTrait, + focalOutcome = focalOutcome, xqtlColoc = xqtlColoc, jointGwas = jointGwas, separateGwas = separateGwas, @@ -1787,8 +2276,11 @@ setMethod( signalScreenParam = signalScreenParam, alleleFlip = alleleFlip, methodArgs = methodArgs, + genotypeFilterParam = genotypeFilterParam, + phenotypeFilterParam = phenotypeFilterParam, residualizationParam = residualizationParam ) + .withGenome(res, build) } ) @@ -1802,7 +2294,8 @@ setMethod( gwasSumStats = NULL, contexts = NULL, traitId = NULL, - focalTrait = NULL, + cisWindow = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -1812,27 +2305,31 @@ setMethod( ) { .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) + .cbAssertFocalOutcome(focalOutcome, xqtlColoc) .cbRequireSumStatsQc(qtlData, "qtlData") + .cbAssertQssRowsSelected(qtlData, contexts, traitId) + build <- .cbBuild(qtlData, gwasSumStats) cutoffs <- .panelCutoffs(panelFilterParam) qtlPairs <- .cbQtlSumStatsBundle( qtlData, contexts = contexts, traitId = traitId, - cutoffs = cutoffs + cutoffs = cutoffs, + cisWindow = cisWindow ) - .cbDriver( + res <- .cbDriver( individualBundle = NULL, qtlPairs = qtlPairs, gwasSumStats = gwasSumStats, xqtlColoc = xqtlColoc, jointGwas = jointGwas, separateGwas = separateGwas, - focalTrait = focalTrait, + focalOutcome = focalOutcome, methodArgs = methodArgs, - qtlLdReference = ldReference(qtlData), alleleFlip = alleleFlip, cutoffs = cutoffs ) + .withGenome(res, build) } ) @@ -1848,7 +2345,7 @@ setMethod( traitId = NULL, region = NULL, cisWindow = NULL, - focalTrait = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -1856,23 +2353,27 @@ setMethod( panelFilterParam = PanelFilterParam(), signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, + genotypeFilterParam = GenotypeFilterParam(), + phenotypeFilterParam = PhenotypeFilterParam(), 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 - # .assertMethodOptions already accepts; anything else must be built. methodArgs = ColocboostOptions() ) { .assertMethodOptions(methodArgs, "ColocboostOptions", "methodArgs") .cbAssertAnyRun(xqtlColoc, jointGwas, separateGwas) - .cbPipelineMultiStudy( + .cbAssertFocalOutcome(focalOutcome, xqtlColoc) + # As in fineMappingPipeline: a context no study has is refused, and + # one only some lack is skipped for those, with a warning. + parseContexts(contexts, qtlData) + .cbMsAssertTraitsSelected(qtlData, contexts, traitId) + build <- .cbBuild(qtlData, gwasSumStats, region) + res <- .cbPipelineMultiStudy( qtlData = qtlData, gwasSumStats = gwasSumStats, contexts = contexts, traitId = traitId, region = region, cisWindow = cisWindow, - focalTrait = focalTrait, + focalOutcome = focalOutcome, xqtlColoc = xqtlColoc, jointGwas = jointGwas, separateGwas = separateGwas, @@ -1881,8 +2382,11 @@ setMethod( signalScreenParam = signalScreenParam, alleleFlip = alleleFlip, methodArgs = methodArgs, + genotypeFilterParam = genotypeFilterParam, + phenotypeFilterParam = phenotypeFilterParam, residualizationParam = residualizationParam ) + .withGenome(res, build) } ) @@ -1896,7 +2400,7 @@ setMethod( traitId, region, cisWindow, - focalTrait, + focalOutcome, xqtlColoc, jointGwas, separateGwas, @@ -1905,43 +2409,81 @@ setMethod( signalScreenParam, alleleFlip, methodArgs, + genotypeFilterParam, + phenotypeFilterParam, residualizationParam ) { - screenSpec <- .screenResolve(signalScreenParam) - indBundle <- .cbMultiStudyIndBundle( - qtlData = qtlData, + cutoffs <- .panelCutoffs(panelFilterParam) + qtlSide <- .cbMultiStudyQtlSide( + qtlData, contexts = contexts, traitId = traitId, region = region, cisWindow = cisWindow, samples = samples, - screenSpec = screenSpec, - residualizationParam = residualizationParam - ) - cutoffs <- .panelCutoffs(panelFilterParam) - ss <- .cbMultiStudySumstats( - qtlData, - contexts, - traitId, + screenSpec = .screenResolve(signalScreenParam), + residualizationParam = residualizationParam, + genotypeFilter = .qtlResolveFilter(genotypeFilterParam), + phenotypeFilter = .cbResolvePhenotypeFilter(phenotypeFilterParam), cutoffs = cutoffs ) .cbDriver( - indBundle, - ss$qtlPairs, + qtlSide$indBundle, + qtlSide$qtlPairs, gwasSumStats, xqtlColoc, jointGwas, separateGwas, - focalTrait, + focalOutcome, methodArgs, - qtlLdReference = ss$qtlLdReference, alleleFlip = alleleFlip, cutoffs = cutoffs ) } +# The QTL side of a MultiStudyQtlDataset run: the individual-level bundle +# across its studies, and the summary-statistic pairs alongside them. +# @noRd +.cbMultiStudyQtlSide <- function( + qtlData, + contexts, + traitId, + region, + cisWindow, + samples, + screenSpec, + residualizationParam, + genotypeFilter, + phenotypeFilter, + cutoffs +) { + list( + indBundle = .cbMultiStudyIndBundle( + qtlData = qtlData, + contexts = contexts, + traitId = traitId, + region = region, + cisWindow = cisWindow, + samples = samples, + screenSpec = screenSpec, + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter + ), + qtlPairs = .cbMultiStudySumstats( + qtlData, + contexts, + traitId, + cisWindow, + cutoffs = cutoffs + )$qtlPairs + ) +} + # One study's bundle with its names study-prefixed, or NULL when it has -# nothing to contribute. +# nothing to contribute. A `contexts` vector applies to every study: each +# runs on the ones it has, and a study with none of them sits out (the entry +# point has warned about it). # @noRd .cbStudyBundle <- function( studyName, @@ -1952,17 +2494,26 @@ setMethod( cisWindow, samples, screenSpec, - residualizationParam = ResidualizationParam() + residualizationParam = ResidualizationParam(), + genotypeFilter, + phenotypeFilter = .qtlKeepAllPhenotypes() ) { + qd <- qtlDatasets[[studyName]] + share <- if (is.null(contexts)) NULL else intersect(contexts, contexts(qd)) + if (!is.null(share) && length(share) == 0L) { + return(NULL) + } sub <- .cbIndividualBundle( - qtlDatasets[[studyName]], - contexts = contexts, + .qtlRestrictSamples(qd, genotypeFilter$keepSamples), + contexts = share, traitId = traitId, region = region, cisWindow = cisWindow, samples = samples, pipCutoffToSkip = screenSpec, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter ) if (is.null(sub)) { return(NULL) @@ -2002,9 +2553,11 @@ setMethod( cisWindow, samples, screenSpec, - residualizationParam = ResidualizationParam() + residualizationParam = ResidualizationParam(), + genotypeFilter, + phenotypeFilter = .qtlKeepAllPhenotypes() ) { - qtlDatasets <- qtlDatasets(qtlData) + qtlDatasets <- as.list(qtlData) subs <- compact(map( names(qtlDatasets), .cbStudyBundle, @@ -2015,11 +2568,21 @@ setMethod( cisWindow = cisWindow, samples = samples, screenSpec = screenSpec, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter )) if (length(subs) == 0L) { return(NULL) } + .cbCombineStudyBundles(subs) +} + +# The per-study bundles as one: X, Y and the outcomes concatenated, and each +# study's dict shifted past the entries the studies before it contributed. +# NULL when no study contributes any X. +# @noRd +.cbCombineStudyBundles <- function(subs) { xOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "X")) yOffsets <- .cbOffsets(map_int(subs, .cbFieldLength, field = "Y")) combinedX <- .cbConcat(map(subs, "X")) @@ -2074,18 +2637,20 @@ setMethod( ) } -# Sumstat side of a MultiStudyQtlDataset: bundle any embedded QtlSumStats. -# Returns list(qtlPairs, qtlLdReference). +# Sumstat side of a MultiStudyQtlDataset: bundle any embedded QtlSumStats, +# with `cisWindow` laid on the tuples selected as a QtlSumStats run lays it. +# Returns list(qtlPairs); each pair carries its own row's LD reference. # @noRd .cbMultiStudySumstats <- function( qtlData, contexts, traitId, + cisWindow, cutoffs = NULL ) { embeddedSs <- sumStats(qtlData) if (is.null(embeddedSs)) { - return(list(qtlPairs = list(), qtlLdReference = NULL)) + return(list(qtlPairs = list())) } .cbRequireSumStatsQc(embeddedSs, "MultiStudyQtlDataset@sumStats") list( @@ -2093,9 +2658,9 @@ setMethod( embeddedSs, contexts = contexts, traitId = traitId, - cutoffs = cutoffs - ), - qtlLdReference = ldReference(embeddedSs) + cutoffs = cutoffs, + cisWindow = cisWindow + ) ) } diff --git a/R/cpp11.R b/R/cpp11.R index 141781de..25978b9a 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -16,14 +16,6 @@ dentistIterativeImputeFactor <- function(factorR, nSample, zScoreR, pValueThresh .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) } diff --git a/R/crossValidation.R b/R/crossValidation.R index b3d5f356..13e66390 100644 --- a/R/crossValidation.R +++ b/R/crossValidation.R @@ -135,9 +135,9 @@ NULL # predicts held-out samples (Xtest[, common] %*% W[common, ]), aggregates the # out-of-fold predictions into full-Y matrices, scores them with .cvMetricRow, # and keys the output via .cvOutputKey(). `maxNumVariants` (optional) randomly -# subsamples variants up front to bound compute; `numThreads` parallelises the -# fold loop (-1 = all cores, 0/1 = serial). -#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam +# subsamples variants up front to bound compute; `BPPARAM` runs the folds +# (SerialParam() one at a time). +#' @importFrom BiocParallel SerialParam #' @importFrom stats sd lm cor #' @importFrom dplyr n_distinct #' @noRd @@ -148,7 +148,7 @@ NULL samplePartitions = NULL, fitFold, fitFoldCtx = NULL, - numThreads = 1, + BPPARAM = SerialParam(), maxNumVariants = NULL, variantsToKeep = NULL, fitRetention = c("none", "slim", "full"), @@ -168,7 +168,6 @@ NULL ) foldIds <- sort(unique(samplePartition$Fold)) st <- proc.time() - numCores <- .cvNumCores(numThreads) cvState <- list( X = X, Y = Y, @@ -180,7 +179,7 @@ NULL verbose = verbose, rngSeed = seed ) - foldResults <- .cvRunFolds(foldIds, cvState, numCores) + foldResults <- .cvRunFolds(foldIds, cvState, BPPARAM) agg <- .cvAggregate(foldResults, Y, verbose) list( samplePartition = samplePartition, @@ -347,29 +346,101 @@ NULL samplePartitions } -# 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. +# ---- BiocParallel ------------------------------------------------------------ + +# Refuse a `BPPARAM` that is not a BiocParallelParam. # @noRd -.cvNumCores <- function(numThreads) { - avail <- multicoreWorkers() - min(if (numThreads == -1) avail else numThreads, avail) +.assertBpparam <- function(BPPARAM, what = "BPPARAM") { + if (methods::is(BPPARAM, "BiocParallelParam")) { + return(invisible(BPPARAM)) + } + abort(glue( + "`{what}` must be a BiocParallelParam, such as SerialParam() or ", + "MulticoreParam(workers = 4) (got {class(BPPARAM)[[1L]]})." + )) } -# 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 -# is the one place a user seed reaches BiocParallel workers, which set.seed() -# in the main process cannot. +# bplapply() on a copy of the caller's BPPARAM seeded by .seededBpparam(). A +# worker's error comes back as BiocParallel's report on every element; the +# first one is raised again with its own message, as a serial map would have +# raised it. The extra arguments reach `.f` through bplapply(), whose own +# formals include X and FUN, so pass an argument of either name by position. # @noRd -.bpSeedParam <- function(numCores, seed = NULL) { - MulticoreParam(workers = numCores, RNGseed = as.integer(seed %||% 1L)) +#' @importFrom BiocParallel bplapply +.bpMap <- function(.x, .f, ..., BPPARAM, seed = NULL) { + try_fetch( + bplapply(.x, .f, ..., BPPARAM = .seededBpparam(BPPARAM, seed)), + bplist_error = .bpRaiseFirstError + ) +} + +# @noRd +.bpRaiseFirstError <- function(cnd) { + failed <- keep(attr(cnd, "result"), .isRemoteError) + if (length(failed) == 0L) { + cnd_signal(cnd) + } + abort(conditionMessage(failed[[1L]])) +} + +# @noRd +.isRemoteError <- function(x) { + methods::is(x, "remote_error") +} + +# The caller's BPPARAM, copied and given the RNG seed its workers draw from: +# `seed` when one is given, else the param's own RNGseed, else one draw from +# the session RNG, so a set.seed() before the call still governs the run. A +# copy is seeded because a BiocParallelParam is a reference object: seeding +# it in place would change the caller's own. Each element then draws from its +# own stream, so the numbers do not depend on the backend or worker count. +# @noRd +#' @importFrom BiocParallel bpRNGseed bpRNGseed<- +.seededBpparam <- function(BPPARAM, seed = NULL) { + copy <- BPPARAM$copy() + bpRNGseed(copy) <- as.integer( + seed %||% bpRNGseed(BPPARAM) %||% .sessionSeedDraw() + ) + copy +} + +# One integer from the session RNG. +# @noRd +.sessionSeedDraw <- function() { + sample.int(.Machine$integer.max, 1L) +} + +# The threads an engine with its own parallelism (OpenMP, a C++ thread pool, +# mclapply) may use under BPPARAM: its worker count when the workers are +# processes on this machine (SerialParam, MulticoreParam), else 1. A +# SnowParam's or BatchtoolsParam's workers can be other machines or +# scheduler jobs, so their count is no budget for threads here. Said once a +# session per backend, as a windowed engine asks once per window. +# @noRd +#' @importFrom BiocParallel bpnworkers +.bpLocalThreads <- function(BPPARAM, caller) { + if ( + methods::is(BPPARAM, "SerialParam") || + methods::is(BPPARAM, "MulticoreParam") + ) { + return(as.integer(bpnworkers(BPPARAM))) + } + backend <- class(BPPARAM)[[1L]] + inform( + glue( + "{caller}: the workers of a {backend} need not run on this ", + "machine, so a threaded engine runs on 1 thread." + ), + .frequency = "once", + .frequency_id = str_c("pecotmr-bpLocalThreads-", backend) + ) + 1L } # Seed the main-process RNG when a seed is supplied. This covers only the serial -# draws (fold partitioning, variant sub-sampling, single-threaded fitting); -# BiocParallel workers seed their own L'Ecuyer streams via .bpSeedParam. A NULL -# seed leaves the session RNG untouched so an outer set.seed() still governs it. +# draws (fold partitioning, variant sub-sampling); BiocParallel workers draw +# from the streams .seededBpparam() seeds. A NULL seed leaves the session RNG +# untouched so an outer set.seed() still governs it. # # Scoped to the CALLER's frame rather than set.seed()'s permanent mutation, so # a seeded call does not leave the user's session RNG changed after it returns. @@ -381,18 +452,16 @@ NULL } } -# Run each fold (parallel via BiocParallel when >= 2 cores). +# Run each fold on BPPARAM's workers. # @noRd -.cvRunFolds <- function(foldIds, cvState, numCores) { - if (numCores >= 2) { - return(bplapply( - foldIds, - .cvRunFold, - cv = cvState, - BPPARAM = .bpSeedParam(numCores, cvState$rngSeed) - )) - } - map(foldIds, .cvRunFold, cv = cvState) +.cvRunFolds <- function(foldIds, cvState, BPPARAM) { + .bpMap( + foldIds, + .cvRunFold, + cv = cvState, + BPPARAM = BPPARAM, + seed = cvState$rngSeed + ) } # Aggregate per-fold predictions + performance across methods. Returns @@ -517,15 +586,58 @@ NULL ) } +# ============================================================================= +# Cross-validation settings +# ----------------------------------------------------------------------------- +# One bundle for both fineMappingPipeline() and twasWeightsPipeline(). The two +# had drifted on a setting that means the same thing in each: `cvFolds` +# defaulted to 0 in fine-mapping and 5 in TWAS. Folding them into one +# constructor is the rule the joint specification already follows. +# +# `folds` is 0 everywhere. twasWeightsPipeline used to default to 5, so the +# 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 `EnsembleParam(enabled =)` defaults to FALSE too, and asking +# for an ensemble +# without folds is an error rather than a silently missing row. +# +# `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: +# +# weightMethods -- selects among TWAS *weight* methods, matching tokens like +# `lasso` / `mrmash` and their `_weights` spellings. Fine mapping's +# `methods=` are fine-mapping methods and its CV refits all of them, so +# there is no weight-method set to select from. It is also the knob that +# decides whether .jointTwasCvBlocked() reaches back for a fold's +# fine-mapping fit -- a TWAS-to-fine-mapping handoff with no counterpart +# in the other direction. +# maxVariants -- caps the CV design matrix for twasWeightsCv(). Fine mapping +# does not use that engine; .fmWeightsCv() has its own loop and only +# mirrors twasWeightsCv()'s output shape. +# +# Both are documented as TWAS-only so the silence is stated, not discovered. +# +# `seed` is not here either. It seeds the whole call in both pipelines +# (fine-mapping wraps the call in withr::local_seed; TWAS also seeds the +# BiocParallel RNG for method fitting), so it is a call-level knob that CV +# happens to benefit from, not a CV setting. +# ============================================================================= + #' @rdname CrossValidationParam #' @aliases CrossValidationParam-class +#' @importClassesFrom BiocParallel BiocParallelParam #' @exportClass CrossValidationParam setClass( "CrossValidationParam", contains = "MethodParam", slots = c( folds = "numeric", - numThreads = "numeric", + BPPARAM = "BiocParallelParam", samplePartition = "list_OR_NULL", maxVariants = "numeric_OR_NULL", weightMethods = "list_OR_NULL", @@ -560,7 +672,7 @@ setValidity("CrossValidationParam", function(object) { #' @description How cross-validation runs, shared by #' \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. #' -#' \code{folds}, \code{numThreads}, \code{samplePartition} and +#' \code{folds}, \code{BPPARAM}, \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 @@ -569,9 +681,12 @@ setValidity("CrossValidationParam", function(object) { #' \code{1} skips cross-validation. The same value in both pipelines --- #' \code{twasWeightsPipeline} used to default to \code{5}, which made an #' unspecified setting mean two different things. -#' @param numThreads Integer. Parallel workers for the per-fold refits. -#' \code{1} (default) is serial; \code{-1} uses all cores. Only consulted -#' when \code{folds > 1}. +#' @param BPPARAM A \code{BiocParallelParam} the per-fold refits run on; +#' \code{SerialParam()} (default) runs them one at a time. Its workers draw +#' from random-number streams seeded by the pipeline's \code{seed}, else by +#' the param's own \code{RNGseed}, else by one draw from the session RNG, +#' so a run gives the same numbers however many workers it has. Only +#' consulted when \code{folds > 1}. #' @param samplePartition Optional pre-defined partition \code{data.frame} #' with columns \code{Sample} and \code{Fold}. When supplied, every method #' reuses this exact partition instead of generating a fresh one. @@ -593,12 +708,12 @@ setValidity("CrossValidationParam", function(object) { #' downstream. #' @return A \code{CrossValidationParam} object, a \code{\link{MethodParam}}. #' @examples -#' CrossValidationParam(folds = 10, numThreads = 4) +#' CrossValidationParam(folds = 10, BPPARAM = BiocParallel::SerialParam()) #' CrossValidationParam(folds = 5, fitFullData = FALSE) #' @export CrossValidationParam <- function( folds = 0, - numThreads = 1, + BPPARAM = SerialParam(), samplePartition = NULL, maxVariants = NULL, weightMethods = NULL, @@ -607,7 +722,7 @@ CrossValidationParam <- function( new( "CrossValidationParam", folds = folds, - numThreads = numThreads, + BPPARAM = .assertBpparam(BPPARAM), samplePartition = samplePartition, maxVariants = maxVariants, weightMethods = weightMethods, @@ -621,7 +736,7 @@ CrossValidationParam <- function( .cvResolve <- function(crossValidationParam) { list( folds = crossValidationParam$folds %||% 0, - numThreads = crossValidationParam$numThreads %||% 1, + BPPARAM = crossValidationParam$BPPARAM %||% SerialParam(), samplePartition = crossValidationParam$samplePartition, # -1 is twasWeightsCv()'s "no cap" sentinel. fineMappingPipeline # resolves these two as well but never reads them. @@ -661,54 +776,15 @@ 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. +# fitFullData = TRUE and BPPARAM = SerialParam() are those fields' defaults. # @noRd .cvFieldIsSet <- function(x) { - if (is.null(x) || isTRUE(x)) { + if (is.null(x) || isTRUE(x) || methods::is(x, "SerialParam")) { return(FALSE) } - # numThreads = 1 and folds = 0 are the no-op defaults. + if (methods::is(x, "BiocParallelParam")) { + return(TRUE) + } + # folds = 0 (or 1) is the no-op default. !(length(x) == 1L && !is.na(x) && is.numeric(x) && (x == 0 || x == 1)) } - -# ============================================================================= -# Cross-validation settings -# ----------------------------------------------------------------------------- -# One bundle for both fineMappingPipeline() and twasWeightsPipeline(). The two -# had drifted on a setting that means the same thing in each: `cvFolds` -# defaulted to 0 in fine-mapping and 5 in TWAS. Folding them into one -# constructor is the rule the joint specification already follows. -# -# `folds` is 0 everywhere. twasWeightsPipeline used to default to 5, so the -# 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 `EnsembleParam(enabled =)` defaults to FALSE too, and asking -# for an ensemble -# without folds is an error rather than a silently missing row. -# -# `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: -# -# weightMethods -- selects among TWAS *weight* methods, matching tokens like -# `lasso` / `mrmash` and their `_weights` spellings. Fine mapping's -# `methods=` are fine-mapping methods and its CV refits all of them, so -# there is no weight-method set to select from. It is also the knob that -# decides whether .jointTwasCvBlocked() reaches back for a fold's -# fine-mapping fit -- a TWAS-to-fine-mapping handoff with no counterpart -# in the other direction. -# maxVariants -- caps the CV design matrix for twasWeightsCv(). Fine mapping -# does not use that engine; .fmWeightsCv() has its own loop and only -# mirrors twasWeightsCv()'s output shape. -# -# Both are documented as TWAS-only so the silence is stated, not discovered. -# -# `seed` is not here either. It seeds the whole call in both pipelines -# (fine-mapping wraps the call in withr::local_seed; TWAS also seeds the -# BiocParallel RNG for method fitting), so it is a call-level knob that CV -# happens to benefit from, not a CV setting. -# ============================================================================= diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index aa02011a..528f5eb9 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -187,7 +187,7 @@ BoundaryMergeParam <- function( #' @section LD block convention: \code{gwasSumStats} is ONE #' \code{\link{GwasSumStats}} whose elements are LD blocks, keyed by its #' \code{blockId} column -- build it with -#' \code{loadGwasSumStatsFromManifest(..., ldBlocks = )}. Per-block +#' \code{loadGwasSumStatsFromManifest(..., region = )}. Per-block #' \code{region_info}, \code{LD_map}, and \code{snp_map} entries are built #' automatically from the LD reference and concatenated before the call to #' \code{ctwas::ctwas_sumstats}. A single-block input is rejected: cTWAS's EM @@ -201,9 +201,10 @@ BoundaryMergeParam <- function( #' 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)}. +#' @section LD reference compatibility check: Per block: the block's GWAS +#' rows must share one LD reference (a block's LD is one matrix), and every +#' weight row placed in the block that carries a reference must be the same +#' LD reference as theirs. Blocks may sit on different references. #' 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 @@ -214,8 +215,8 @@ BoundaryMergeParam <- function( #' #' @param gwasSumStats A \code{\link{GwasSumStats}} whose elements are LD #' blocks (at least two), keyed by its \code{blockId} column, with -#' \code{qcInfo()} non-empty. Build it with -#' \code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it +#' \code{qcOptions()} non-empty. Build it with +#' \code{loadGwasSumStatsFromManifest(..., region = )} and pass it #' through \code{\link{summaryStatsQc}}. #' @param twasWeights The per-gene weight source. Either (a) a FLAT #' \code{\link{TwasWeights}} / \code{QtlFineMappingResult} (or a homogeneous @@ -228,28 +229,41 @@ BoundaryMergeParam <- function( #' where only a few of many LD blocks carry gene weights). A gene whose cis #' span straddles a block boundary is homed by its single anchor; the #' cross-block signal is cTWAS's boundary-gene concern -#' (\code{\link{mergeCtwasBoundaryRegions}}), not placement. +#' (\code{\link{mergeCtwasBoundaryRegions}}), not placement. A +#' \code{TwasWeights} row of the run's method that carries a SuSiE fit and +#' was narrowed since that fit warns (condition class +#' \code{pecotmrFitCoverage}): the fit no longer lines up with the row's +#' variants, so its weights are not renormalized over the variants kept. #' @param twasZ Optional \code{GRanges} of TWAS Z-scores (output of #' \code{\link{causalInferencePipeline}}). When supplied, the per-(trait, #' context) Z is used as the \code{z_gene} input to \code{ctwas_sumstats} so #' it is not recomputed. -#' @param fineMappingResult Optional \code{QtlFineMappingResult} or -#' \code{GwasFineMappingResult} carrying the per-variant PIP and credible-set -#' membership data used by the CS / PIP rescue filters (\code{csMinCor} and -#' \code{minPipCutoff}). When \code{NULL} (default) the smart filters are -#' no-ops; only the magnitude filter (\code{twasWeightCutoff}) and the -#' per-gene cap (\code{maxNumVariants}, ordered by \code{|weight|}) apply. -#' @param method Optional character (length 1). Picks which TWAS method's -#' weights to feed into ctwas for each (study, context, trait) gene. When -#' \code{NULL} (default): use \code{"ensemble"} if that method is present -#' across the weight sources; otherwise use the sole method when only one is -#' 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. +#' @param fineMappingResult Optional \code{QtlFineMappingResult}: the genes' +#' own fine-mapping, whose per-variant PIP and credible-set membership the +#' CS / PIP rescue filters (\code{csMinCor} and \code{minPipCutoff}) read. +#' Each gene is looked up by its weights' \code{(study, context, trait)} in +#' the fits of \code{fineMappingMethod}; a gene with no fit there gets no +#' rescue. When \code{NULL} (default) the smart filters are no-ops; only the +#' magnitude filter (\code{twasWeightCutoff}) and the per-gene cap +#' (\code{maxNumVariants}, ordered by \code{|weight|}) apply. +#' @param fineMappingMethod Character (length 1): the method of +#' \code{fineMappingResult} whose fits the rescues read, e.g. +#' \code{"susie"}. Required with a \code{fineMappingResult}, since the +#' weights' own method -- an \code{"ensemble"} or \code{"lasso"} weight -- +#' names no fine-mapping fit. Default \code{NULL}. +#' @param method Character (length 1): which TWAS method's weights to feed +#' into ctwas for each (study, context, trait) gene, one method per run. +#' \code{NULL} (default) uses the pre-combined \code{"ensemble"} weights of +#' \code{TwasWeights}. Weights with no ensemble, and fine-mapping results as +#' the weight source, have no default: name the method (e.g. +#' \code{"mrash"}, or a fine-mapping method such as \code{"susie"}). #' @param maxNumSingleEffects Integer. Max number of single effects in cTWAS #' fine-mapping. Default \code{5}. Pass-through to #' \code{ctwas::ctwas_sumstats}. -#' @param numThreads Number of cores. Default \code{1}. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the cores +#' ctwas's own \code{ncore} parallelism uses when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' core. Default \code{SerialParam()}. #' @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 @@ -267,22 +281,25 @@ BoundaryMergeParam <- function( #' \code{FALSE}), \code{pipThreshold}, \code{filterCs} and #' \code{maxSnp}. #' @param keepSnps Logical (length 1). When \code{TRUE}, retain the -#' context-agnostic SNP background of each run as one extra \code{CtwasResult} -#' row (\code{study = context = "SNP"}, mirroring cTWAS's own \code{"SNP"} -#' group) so the full ctwas output is reconstructable from +#' context-agnostic SNP background of each run as extra \code{CtwasResult} +#' rows, one per region (\code{study = context = "SNP"}, mirroring cTWAS's +#' own \code{"SNP"} group) so the full ctwas output is reconstructable from #' \code{\link{ctwasPosteriors}} / \code{susieAlpha}. Default \code{FALSE} -- #' the SNP rows are the null background and are dropped from the structured #' gene-level result. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what #' the ctwas steps accept between them. -#' @return A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, -#' study, context, method)}. A single-context run is one row per method; a -#' multi-context (joint) run emits per-context rows sharing the same -#' \code{jointContexts} set and the jointly-estimated group priors. Each row's -#' \code{\link{CtwasResultEntry}} payload carries that context's per-gene -#' fine-mapping posteriors (\code{finemap}), the run's \code{param}, and its -#' \code{regionInfo}. For the raw \code{ctwas::finemap_regions} list (e.g. to +#' @return A \code{\link{CtwasResult}} collection: one row per +#' \code{(gwasStudy, study, context, method)} run and cTWAS region. A +#' single-context run gives each method its own rows; a multi-context +#' (joint) run emits per-context rows sharing the same \code{jointContexts} +#' set and the jointly-estimated group priors. Each row holds that region's +#' per-gene fine-mapping posteriors as ranges, with the region's per-effect +#' susie alpha table (\code{susieAlpha}), its \code{regionInfo} and the +#' run's \code{groupPriors} in \code{mcols()}. Its \code{seqinfo()} names +#' the genome build the inputs name; inputs naming different builds are +#' refused. For the raw \code{ctwas::finemap_regions} list (e.g. to #' feed \code{\link{mergeCtwasBoundaryRegions}}), call the granular #' \code{\link{assembleCtwasInputs}} \eqn{\to} #' \code{\link{estCtwasGroupPriors}} \eqn{\to} @@ -300,12 +317,11 @@ BoundaryMergeParam <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldReference = ldStem, region = "chr22:10000000-19000000", -#' ldBlocks = blocks) +#' ldReference = ldStem, which = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' ctwasPipeline(gwasSumStats = gwasByRegion, -#' twasWeights = list(ctwasWeightsExample), +#' twasWeights = list(ctwasWeightsExample), method = "susie", #' ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), #' methodArgs = CtwasOptions( @@ -320,9 +336,10 @@ ctwasPipeline <- function( twasWeights, twasZ = NULL, fineMappingResult = NULL, + fineMappingMethod = NULL, method = NULL, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), ctwasPriorParam = CtwasPriorParam(), variantPruningParam = VariantPruningParam(), boundaryMergeParam = BoundaryMergeParam(), @@ -335,34 +352,44 @@ ctwasPipeline <- function( boundaryMergeParam, methodArgs ) + .assertBpparam(BPPARAM) .ctwasRequireNamedLists(gwasSumStats, twasWeights) - methods <- .ctwasResolveMethods(twasWeights, method) - gwasStudy <- .ctwasGwasStudy(gwasSumStats) - rows <- list_flatten(map( - methods, - .ctwasRunMethod, + build <- .inputsBuild( + list(gwasSumStats, twasWeights, twasZ, fineMappingResult), + "ctwasPipeline" + ) + method <- .ctwasResolveMethod(twasWeights, method) + .ctwasCheckFitCoverage(twasWeights, method, "ctwasPipeline()") + rows <- .ctwasRunMethod( + method, gwasSumStats = gwasSumStats, twasWeights = twasWeights, twasZ = twasZ, fineMappingResult = fineMappingResult, + fineMappingMethod = fineMappingMethod, variantPruningParam = variantPruningParam, ctwasPriorParam = ctwasPriorParam, - numThreads = numThreads, + BPPARAM = BPPARAM, maxNumSingleEffects = maxNumSingleEffects, boundaryMergeParam = boundaryMergeParam, - gwasStudy = gwasStudy, + gwasStudy = .ctwasGwasStudy(gwasSumStats), keepSnps = keepSnps, methodArgs = methodArgs - )) - if (length(rows) == 0L) { - msg <- glue( - "ctwasPipeline: no genes were modeled (the weight sources ", - "produced no usable gene weights for method(s): ", - "{str_flatten(methods, ', ')})." - ) - abort(msg) + ) + .ctwasRequireRows(rows, method) + .withGenome(.ctwasRowsToResult(rows), build) +} + +# A run that modeled no gene has no result to return. +# @noRd +.ctwasRequireRows <- function(rows, method) { + if (length(rows) > 0L) { + return(invisible(NULL)) } - .ctwasRowsToResult(rows) + abort(glue( + "ctwasPipeline: no genes were modeled (the weight sources ", + "produced no usable gene weights for method '{method}')." + )) } # The cTWAS run proper: estimate the group priors, screen regions against @@ -375,24 +402,24 @@ ctwasPipeline <- function( ctwasPriorParam, boundaryMergeParam, maxNumSingleEffects, - numThreads, + BPPARAM, methodArgs ) { est <- estCtwasGroupPriors( inputs, ctwasPriorParam = ctwasPriorParam, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) screened <- screenCtwasRegions( est, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) finemap <- finemapCtwasRegions( screened, maxNumSingleEffects = maxNumSingleEffects, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) if (!isTRUE(boundaryMergeParam$enabled)) { @@ -402,14 +429,13 @@ ctwasPipeline <- function( finemap, boundaryMergeParam = boundaryMergeParam, maxNumSingleEffects = maxNumSingleEffects, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) } # One cTWAS run for method `m`: assemble inputs -> estimate params -> screen -> -# fine-map (optionally boundary-merge) -> per-context row-specs. `cfg` bundles -# the ctwasPipeline arguments (incl. the `CtwasOptions` option list). +# fine-map (optionally boundary-merge) -> per-context row-specs. # @noRd .ctwasRunMethod <- function( m, @@ -417,29 +443,32 @@ ctwasPipeline <- function( twasWeights, twasZ, fineMappingResult, + fineMappingMethod, variantPruningParam, ctwasPriorParam, - numThreads, + BPPARAM, maxNumSingleEffects, boundaryMergeParam, gwasStudy, keepSnps, methodArgs ) { - inputs <- assembleCtwasInputs( + # ctwasPipeline() has already warned about the rows whose fits this reads. + inputs <- .muffleFitCoverage(assembleCtwasInputs( gwasSumStats = gwasSumStats, twasWeights = twasWeights, twasZ = twasZ, fineMappingResult = fineMappingResult, + fineMappingMethod = fineMappingMethod, method = m, variantPruningParam = variantPruningParam - ) + )) merged <- .ctwasRunStages( inputs, ctwasPriorParam = ctwasPriorParam, boundaryMergeParam = boundaryMergeParam, maxNumSingleEffects = maxNumSingleEffects, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) .ctwasRunToRows( @@ -457,7 +486,7 @@ ctwasPipeline <- function( posteriors, boundaryMergeParam, maxNumSingleEffects, - numThreads, + BPPARAM, methodArgs ) { # The bundle's terminal; mergeCtwasBoundaryRegions() takes scalars. @@ -473,7 +502,7 @@ ctwasPipeline <- function( filterCs = mergeFilterCs, maxSNP = mergeMaxSNP, maxNumSingleEffects = maxNumSingleEffects, - numThreads = numThreads, + BPPARAM = BPPARAM, methodArgs = methodArgs ) } @@ -509,18 +538,18 @@ ctwasPipeline <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldReference = ldStem, region = "chr22:10000000-19000000", -#' ldBlocks = blocks) +#' ldReference = ldStem, which = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' assembleCtwasInputs(gwasSumStats = gwasByRegion, -#' twasWeights = list(ctwasWeightsExample)) +#' twasWeights = list(ctwasWeightsExample), method = "susie") #' @export assembleCtwasInputs <- function( gwasSumStats, twasWeights, twasZ = NULL, fineMappingResult = NULL, + fineMappingMethod = NULL, method = NULL, variantPruningParam = VariantPruningParam() ) { @@ -528,43 +557,52 @@ assembleCtwasInputs <- function( variantPruningParam, "VariantPruningParam" ) - # The bundle's terminal: .ctwasBuildWeights and below take scalars. - twasWeightCutoff <- variantPruningParam$weightCutoff - csMinCor <- variantPruningParam$csMinCor - minPipCutoff <- variantPruningParam$pipRescue - maxNumVariants <- variantPruningParam$maxVariants .ctwasValidateGwasList(gwasSumStats) globalPanelInfo <- .ctwasGlobalPanelInfo(gwasSumStats) gwasSumStats <- .ctwasGwasByBlock(gwasSumStats) twasWeights <- .ctwasResolveAndValidateWeights(twasWeights, gwasSumStats) .ctwasValidateOptional(twasZ, fineMappingResult) + fineMappingResult <- .ctwasRescueSource( + fineMappingResult, + fineMappingMethod + ) regionIds <- names(gwasSumStats) resolvedMethod <- .ctwasResolveMethod(twasWeights, method) + .ctwasCheckFitCoverage( + twasWeights, + resolvedMethod, + "assembleCtwasInputs()" + ) fp <- .ctwasFirstPass( regionIds, gwasSumStats, twasWeights, globalPanelInfo ) - globalGwasSnpIds <- unique(list_c(map(fp$zSnpPieces, "id"))) - cutoffs <- list( - twasWeightCutoff = twasWeightCutoff, - csMinCor = csMinCor, - minPipCutoff = minPipCutoff, - maxNumVariants = maxNumVariants - ) weightsList <- .ctwasSecondPass( regionIds, twasWeights, resolvedMethod, fp, fineMappingResult, - cutoffs, - globalGwasSnpIds + .ctwasPruningCutoffs(variantPruningParam), + unique(list_c(map(fp$zSnpPieces, "id"))) ) .ctwasAssembleResult(regionIds, fp, weightsList, twasZ, resolvedMethod) } +# The bundle's terminal: .ctwasBuildWeights and below take scalars, under the +# names they have always had there. +# @noRd +.ctwasPruningCutoffs <- function(variantPruningParam) { + list( + twasWeightCutoff = variantPruningParam$weightCutoff, + csMinCor = variantPruningParam$csMinCor, + minPipCutoff = variantPruningParam$pipRescue, + maxNumVariants = variantPruningParam$maxVariants + ) +} + # Validate the gwasSumStats input: ctwas available, a QC'd GwasSumStats whose # elements are per-LD-block (>= 2 of them). # @@ -580,7 +618,7 @@ assembleCtwasInputs <- function( msg <- glue( "`gwasSumStats` must be a GwasSumStats whose elements are LD ", "blocks (got {class(gwasSumStats)[[1L]]}). Build one with ", - "`loadGwasSumStatsFromManifest(..., ldBlocks = )`." + "`loadGwasSumStatsFromManifest(..., region = )`." ) abort(msg) } @@ -605,7 +643,7 @@ assembleCtwasInputs <- function( # The collection must be QC'd, and its block keys must be usable as region ids. # @noRd .ctwasValidateGwasEntries <- function(gwasSumStats) { - if (length(qcInfo(gwasSumStats)) == 0L) { + if (length(qcOptions(gwasSumStats)) == 0L) { msg <- glue( "assembleCtwasInputs: `gwasSumStats` has no QC record. ", "Call summaryStatsQc() first." @@ -628,8 +666,8 @@ assembleCtwasInputs <- function( } # One single-element GwasSumStats per LD block, keyed by blockId -- the shape -# the two-pass assembly consumes. The collection's own ldReference rides along -# on each subset, so per-region LD lookups are unchanged. +# the two-pass assembly consumes. Each block keeps its own row's LD reference, +# so per-region LD lookups read the panel that block was harmonized against. # @noRd .ctwasGwasByBlock <- function(gwasSumStats) { set_names( @@ -638,23 +676,20 @@ assembleCtwasInputs <- function( ) } -# One block's slice of the collection. `[` carries the collection-level -# 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 -# the same way summaryStatsQc narrows the sketch it retains. +# One block's slice of the collection. A row's LD reference can cover far more +# than its block -- combineGwasSumStats() unions the per-piece panels of one +# source -- so without narrowing here a block would reference 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 the same way +# summaryStatsQc narrows the sketch it retains. # @noRd .ctwasPickBlock <- function(i, x) { block <- x[i] - sketch <- ldReference(block) - if (is.null(sketch)) { + refs <- ldReference(block) + if (length(refs) == 0L) { return(block) } - methods::initialize( - block, - ldReference = .subsetLdRefToIds(sketch, as.list(block)) - ) + .withRowLdRefs(block, .subsetLdRefToIds(refs[[1L]], as.list(block))) } # Resolve a flat weight source into per-region buckets (cTWAS's p0 start-of- @@ -720,18 +755,55 @@ assembleCtwasInputs <- function( ) abort(msg) } + # The rescues keep a gene's weight variants by that gene's own fine-mapping, + # which is a QTL fit: the weights come from a TwasWeights or a + # QtlFineMappingResult, and a GWAS result is keyed by a study and method + # that no gene shares. if ( !is.null(fineMappingResult) && - !methods::is(fineMappingResult, "FineMappingResultBase") + !methods::is(fineMappingResult, "QtlFineMappingResult") ) { msg <- glue( - "`fineMappingResult` must be a FineMappingResultBase ", - "(QtlFineMappingResult or GwasFineMappingResult) or NULL." + "`fineMappingResult` must be a QtlFineMappingResult -- the genes' ", + "own fine-mapping -- or NULL." ) abort(msg) } } +# The fine-mapping the rescues read: `fineMappingResult` narrowed to the one +# method `fineMappingMethod` names. The weights' own method cannot pick it -- +# an "ensemble", "lasso" or "mrash" weight has no fine-mapping fit of that +# name -- so the method is named separately, and is required with a result. +# @noRd +.ctwasRescueSource <- function(fineMappingResult, fineMappingMethod) { + assertString(fineMappingMethod, null.ok = TRUE) + if (is.null(fineMappingResult)) { + if (!is.null(fineMappingMethod)) { + abort(glue( + "`fineMappingMethod` names a method of `fineMappingResult`, ", + "which was not given." + )) + } + return(NULL) + } + available <- unique(as.character(fineMappingResult$method)) + if (is.null(fineMappingMethod)) { + abort(glue( + "`fineMappingResult` is given, so `fineMappingMethod` must name ", + "the method of it whose PIPs and credible sets the rescues read ", + "(available: {str_flatten(available, ', ')})." + )) + } + if (!is_in(fineMappingMethod, available)) { + abort(glue( + "`fineMappingMethod` '{fineMappingMethod}' is not a method of ", + "`fineMappingResult` (available: {str_flatten(available, ', ')})." + )) + } + fineMappingResult[fineMappingResult$method == fineMappingMethod] +} + # 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,32 +811,45 @@ assembleCtwasInputs <- function( # measured against this table rather than against any one block's panel. # # NULL when the collection carries no sketch -- .ctwasRegionGwasLd() reports -# that case with its own message, so this must not pre-empt it. +# that case with its own message, so this must not pre-empt it. Rows on +# different references contribute each panel's variants, each once. # @noRd .ctwasGlobalPanelInfo <- function(gwasSumStats) { - sketch <- ldReference(gwasSumStats) - if (is.null(sketch)) { + refs <- ldReference(gwasSumStats) + if (length(refs) == 0L) { return(NULL) } - .ctwasSnpInfoForBlock(sketch) + info <- list_rbind(map(unname(refs), .ctwasSnpInfoForBlock)) + filter(info, !duplicated(.data$id)) } -# One region's GWAS LD sketch, checked against the region's weights. +# One region's GWAS LD sketch, checked against the region's weights. A +# region's LD is one matrix, so its GWAS rows must share one reference, and +# every weight row in the region is combined with them. # @noRd .ctwasRegionGwasLd <- function(rid, gwasSumStats, twasWeights) { - gwasLd <- ldReference(gwasSumStats[[rid]]) - if (is.null(gwasLd)) { + gwas <- gwasSumStats[[rid]] + refs <- ldReference(gwas) + if (length(refs) == 0L) { msg <- glue( "ctwasPipeline: GwasSumStats for region '{rid}' carries no ", "ldReference (ldReference = NULL); cTWAS requires an LD reference." ) abort(msg) } + if (length(refs) > 1L) { + msg <- glue( + "ctwasPipeline: GwasSumStats for region '{rid}' has rows on ", + "{length(refs)} different LD references; a region's LD is one ", + "matrix." + ) + abort(msg) + } tw <- twasWeights[[rid]] if (!is.null(tw)) { - .ctwasRequireMatchingLdRefs(ldReference(tw), gwasLd) + .ctwasRequireMatchingLdRefs(tw, gwas) } - gwasLd + refs[[1L]] } # @noRd @@ -975,7 +1060,10 @@ assembleCtwasInputs <- function( #' \code{fallbackToPrefit} -- when \code{TRUE}, an accurate EM that fails #' on a degenerate input is recovered by re-running only the prefit step #' and returning those (typically finite) priors. -#' @param numThreads Number of cores. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the cores +#' ctwas's own \code{ncore} parallelism uses when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' core. Default \code{SerialParam()}. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what #' the ctwas steps accept between them. @@ -996,27 +1084,28 @@ assembleCtwasInputs <- function( estCtwasGroupPriors <- function( inputs, ctwasPriorParam = CtwasPriorParam(), - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) { .assertMethodParam(ctwasPriorParam, "CtwasPriorParam") .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") + .assertBpparam(BPPARAM) if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for estCtwasGroupPriors.") } - numThreads <- as.integer(numThreads) + threads <- .bpLocalThreads(BPPARAM, "estCtwasGroupPriors") inputs <- .ctwasResolveLdPaths(inputs) - zGene <- .ctwasEnsureZGene(inputs, numThreads, methodArgs$geneZ) + zGene <- .ctwasEnsureZGene(inputs, threads, methodArgs$geneZ) regionData <- .ctwasAssembleRegionData( inputs, zGene, ctwasPriorParam$thin, - numThreads, + threads, methodArgs$regionData ) boundaryGenes <- .ctwasBoundaryGenes( inputs, - numThreads, + threads, methodArgs$boundaryGenes ) paramRes <- .ctwasEstParamOrFallback( @@ -1024,7 +1113,7 @@ estCtwasGroupPriors <- function( ctwasPriorParam$niterPrefit, ctwasPriorParam$niter, ctwasPriorParam$varStructure, - numThreads, + threads, ctwasPriorParam$thin, ctwasPriorParam$fallbackToPrefit, methodArgs$estParam @@ -1051,7 +1140,7 @@ estCtwasGroupPriors <- function( niterPrefit, niter, groupPriorVarStructure, - numThreads, + threads, thin, fallbackToPrefit, extra @@ -1064,7 +1153,7 @@ estCtwasGroupPriors <- function( niterPrefit, niter, groupPriorVarStructure, - numThreads, + threads, extra )) } @@ -1074,7 +1163,7 @@ estCtwasGroupPriors <- function( niterPrefit, niter, groupPriorVarStructure, - numThreads, + threads, extra ), error = function(cnd) { @@ -1088,7 +1177,7 @@ estCtwasGroupPriors <- function( niter = as.integer(niter), groupPriorVarStructure = groupPriorVarStructure, thin = thin, - numThreads = numThreads, + threads = threads, extra = extra ) } @@ -1106,7 +1195,10 @@ estCtwasGroupPriors <- function( #' #' @param screenResult A list returned by \code{\link{screenCtwasRegions}}. #' @param maxNumSingleEffects Pass-through. -#' @param numThreads Number of cores. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the cores +#' ctwas's own \code{ncore} parallelism uses when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' core. Default \code{SerialParam()}. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what #' the ctwas steps accept between them. @@ -1125,12 +1217,11 @@ estCtwasGroupPriors <- function( #' IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), #' blockId = c("chr22_1", "chr22_2")) #' gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", -#' ldReference = ldStem, region = "chr22:10000000-19000000", -#' ldBlocks = blocks) +#' ldReference = ldStem, which = blocks) #' gwasByRegion <- summaryStatsQc(gss, #' panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) #' inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, -#' twasWeights = list(ctwasWeightsExample)) +#' twasWeights = list(ctwasWeightsExample), method = "susie") #' est <- estCtwasGroupPriors(inp, #' ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, #' fallbackToPrefit = TRUE), @@ -1146,18 +1237,20 @@ estCtwasGroupPriors <- function( finemapCtwasRegions <- function( screenResult, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) { .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") + .assertBpparam(BPPARAM) if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for finemapCtwasRegions.") } + threads <- .bpLocalThreads(BPPARAM, "finemapCtwasRegions") screenResult <- .ctwasResolveLdPaths(screenResult) fmRes <- .ctwasFinemapOrEmpty( screenResult, maxNumSingleEffects, - numThreads, + threads, methodArgs ) # Repair cTWAS's molecular_id mislabel (first-"|" split of our composite @@ -1211,7 +1304,10 @@ finemapCtwasRegions <- function( #' \code{Inf}. #' @param maxNumSingleEffects Integer. Max number of single effects for the #' merged-region re-fine-mapping (LD path only). Default \code{5}. -#' @param numThreads Number of cores. Default \code{1}. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the cores +#' ctwas's own \code{ncore} parallelism uses when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' core. Default \code{SerialParam()}. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what #' the ctwas steps accept between them. @@ -1231,13 +1327,15 @@ mergeCtwasBoundaryRegions <- function( filterCs = FALSE, maxSNP = Inf, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) { .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") + .assertBpparam(BPPARAM) if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for mergeCtwasBoundaryRegions.") } + threads <- .bpLocalThreads(BPPARAM, "mergeCtwasBoundaryRegions") finemapResult <- .ctwasResolveLdPaths(finemapResult) fmRes <- finemapResult$finemap_res if (is.null(fmRes) || nrow(fmRes) == 0L) { @@ -1253,7 +1351,7 @@ mergeCtwasBoundaryRegions <- function( pipThresh, filterCs, maxSNP, - numThreads + threads ) fa <- .ctwasMergeDispatch(finemapResult, common, maxNumSingleEffects) # Flatten the record before merging: c() on a list and a MethodOptions (a @@ -1273,7 +1371,7 @@ mergeCtwasBoundaryRegions <- function( pipThresh, filterCs, maxSNP, - numThreads + threads ) { list( region_info = finemapResult$region_info, @@ -1289,7 +1387,7 @@ mergeCtwasBoundaryRegions <- function( pip_thresh = pipThresh, filter_cs = filterCs, maxSNP = maxSNP, - ncore = as.integer(numThreads) + ncore = threads ) } @@ -1352,7 +1450,7 @@ mergeCtwasBoundaryRegions <- function( niter, groupPriorVarStructure, thin, - numThreads, + threads, extra = list() ) { fitEm <- utils::getFromNamespace("fit_EM", "ctwas") @@ -1361,7 +1459,7 @@ mergeCtwasBoundaryRegions <- function( region_data = fitRegionData, niter = as.integer(niter), group_prior_var_structure = groupPriorVarStructure, - ncore = as.integer(numThreads) + ncore = threads ) prefit <- .ctwasInvoke(fitEm, fitArgs, extra) adj <- .ctwasApplyThin(prefit$group_prior, prefit$group_size, thin) @@ -1427,48 +1525,122 @@ mergeCtwasBoundaryRegions <- function( # Internal helpers # ============================================================================= -# LD-sketch compatibility check. Thin wrapper over the shared -# `.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 -# TwasWeights collection that may carry multiple methods per -# (study, context, trait). Rules: -# - Caller-supplied method (non-NULL, non-empty) wins, provided that -# method exists in the TwasWeights's `method` column. -# - Otherwise prefer "ensemble" when present. -# - Otherwise return the sole method when only one is present. -# - Otherwise: error. -# @noRd -.ctwasResolveMethod <- function(twasWeightsList, method = NULL) { - available <- unique(list_c(map(twasWeightsList, .ctwasMethodChr))) +# LD-sketch compatibility check for one region: every weight row in it is +# combined with every one of its GWAS rows. Thin wrapper over the shared +# `.requireMatchingRowLdRefs` helper (R/ld.R). +.ctwasRequireMatchingLdRefs <- function(tw, gwas) { + nTw <- length(tw) + nGwas <- length(gwas) + .requireMatchingRowLdRefs( + tw, + gwas, + qtlRows = rep(seq_len(nTw), each = nGwas), + gwasRows = rep(seq_len(nGwas), times = nTw), + pipelineName = "ctwasPipeline", + label = "twasWeights" + ) +} + +# Which TWAS method's weights a cTWAS run feeds into ctwas -- one per run, as +# weights are homogeneous within a run. `twasWeights` is a flat weight source +# or a list of them. A caller-supplied `method` is used once checked present. +# Without one, TwasWeights default to their pre-combined "ensemble" weights. +# Anything else has no default: TwasWeights without an ensemble leave several +# methods to choose between, and a fine-mapping result's weights come from +# one of its fine-mapping methods. +# @noRd +.ctwasResolveMethod <- function(twasWeights, method = NULL) { + sources <- .ctwasWeightSources(twasWeights) + available <- unique(.ctwasConcatChr(map(sources, .ctwasMethodsOf))) if (length(available) == 0L) { - abort("ctwasPipeline: TwasWeights collections have no method entries.") + abort("ctwasPipeline: the weight sources carry no method entries.") } if (!is.null(method) && str_length(method) > 0L) { if (!is_in(method, available)) { msg <- glue( - "ctwasPipeline: method '{method}' not present in TwasWeights ", - "(available: {str_flatten(available, ', ')})." + "ctwasPipeline: method '{method}' not present in the weight ", + "sources (available: {str_flatten(available, ', ')})." ) abort(msg) } return(method) } - if (is_in("ensemble", available)) { + allTwas <- all(map_lgl(sources, methods::is, "TwasWeights")) + if (allTwas && is_in("ensemble", available)) { return("ensemble") } - if (length(available) == 1L) { - return(available[[1L]]) + abort(glue( + "ctwasPipeline: pass `method` to choose the weights. ", + "{.ctwasNoDefaultMethod(allTwas)} ", + "(available: {str_flatten(available, ', ')})." + )) +} + +# Why the weight sources have no default method, for the error above. +# @noRd +.ctwasNoDefaultMethod <- function(allTwas) { + if (allTwas) { + return("These TwasWeights carry no 'ensemble' weights to default to") } - msg <- glue( - "ctwasPipeline: TwasWeights carries multiple methods ", - "({str_flatten(available, ', ')}) with no 'ensemble' entry. ", - "Supply a `method` argument to pick one (e.g. method = \"mrash\")." + str_c( + "A fine-mapping result's weights come from one of its fine-mapping ", + "methods" + ) +} + +# The weight sources a `twasWeights` argument holds: itself when it is one +# flat source, else the non-NULL elements of its list. +# @noRd +.ctwasWeightSources <- function(twasWeights) { + if ( + methods::is(twasWeights, "TwasWeights") || + methods::is(twasWeights, "QtlFineMappingResult") + ) { + return(list(twasWeights)) + } + compact(as.list(twasWeights)) +} + +# Warn once about the narrowed rows whose fits a run with `method` reads: the +# TwasWeights rows of that method carrying a SuSiE fit, which renormalizes a +# weight whose variants shrank. A narrowed row's fit no longer lines up with +# its variants, so its weights go in without that step. Other weights are +# used as the row holds them, and a fine-mapping weight source supplies its +# topLoci effects, not its fit. +# @noRd +.ctwasCheckFitCoverage <- function(twasWeights, method, caller) { + sources <- keep( + .ctwasWeightSources(twasWeights), + methods::is, + "TwasWeights" + ) + .fitCoverageCheckedAll( + map(sources, .ctwasSusieFitRows, method = method), + caller ) - abort(msg) +} + +# The rows of TwasWeights `tw` fitted by `method` whose stored fit is a SuSiE +# fit, or NULL when it has none. +# @noRd +.ctwasSusieFitRows <- function(tw, method) { + fits <- mcols(tw, use.names = FALSE)$fits + susie <- map_lgl(seq_along(tw), .ctwasRowHasSusieFit, fits = fits) + rows <- which(as.character(tw$method) == method & susie) + if (length(rows) == 0L) NULL else tw[rows] +} + +# @noRd +.ctwasRowHasSusieFit <- function(i, fits) { + .ctwasIsSusieFit(fits[[i]]) +} + +# @noRd +.ctwasConcatChr <- function(pieces) { + if (length(pieces) == 0L) { + return(character(0)) + } + as.character(list_c(pieces)) } # Fail fast on the two cTWAS inputs. `gwasSumStats` defines the LD-block grid: @@ -1482,7 +1654,7 @@ mergeCtwasBoundaryRegions <- function( msg <- glue( "`gwasSumStats` must be a GwasSumStats whose elements are LD ", "blocks (got {class(gwasSumStats)[[1L]]}). Build one with ", - "`loadGwasSumStatsFromManifest(..., ldBlocks = )`." + "`loadGwasSumStatsFromManifest(..., region = )`." ) abort(msg) } @@ -1500,13 +1672,6 @@ mergeCtwasBoundaryRegions <- function( } } -# Strip a leading "chr" and case so region_id-derived seqnames ("chr22") and -# phenotype rowRanges seqnames ("22" / "chr22") compare equal for placement. -# @noRd -.ctwasChrKey <- function(x) { - str_remove(str_to_lower(as.character(x)), "^chr") -} - # TRUE when `tw` is ALREADY a per-region named list (the pre-bucketed contract): # a NAMED plain list (not an S4 collection) of weight collections. Its keys are # validated against the block grid downstream (the `extra_tw_keys` check). A @@ -1556,65 +1721,25 @@ mergeCtwasBoundaryRegions <- function( abort(msg) } -# One block id parsed into chrom/start/end, or the unplaced sentinel when it -# does not parse as a range. -# @noRd -.ctwasBlockCoords <- function(id) { - g <- try_fetch( - asGranges(str_replace( - as.character(id), - "_([0-9]+)_([0-9]+)$", - ":\\1-\\2" - )), - error = function(cnd) NULL - ) - if (is.null(g) || length(g) < 1L) { - return(list(chrom = "chrUn", start = 1L, end = 0L)) - } - list( - chrom = as.character(GenomicRanges::seqnames(g))[[1L]], - start = GenomicRanges::start(g)[[1L]], - end = GenomicRanges::end(g)[[1L]] - ) -} - -# 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( - map_chr(coords, "chrom"), - IRanges::IRanges( - start = map_int(coords, "start"), - end = map_int(coords, "end") - ) - ) -} - # Place each gene (row) of a flat weight source into its home LD block. The # anchor is start(region) -- matching cTWAS's own `assign_region_data` rule, # which homes a gene by its p0 (single point) into the block where -# p0 in [start, stop). Returns a region_id per row (NA when the anchor falls in -# no block). A gene whose cis SPAN straddles a boundary is still homed by its -# single anchor here; the cross-block signal is cTWAS's boundary-gene concern -# (get_boundary_genes / postprocess_region_merging), not placement. +# p0 in [start, stop), each block's [start, stop) being the one its +# region_info carries (.ctwasBuildSingleRegionInfo()). Returns a region_id per +# row (NA when the anchor falls in no block). A gene whose cis SPAN straddles +# a boundary is still homed by its single anchor here; the cross-block signal +# is cTWAS's boundary-gene concern (get_boundary_genes / +# postprocess_region_merging), not placement. # @noRd .ctwasPlaceByAnchor <- function(region, gwasSumStats) { ids <- names(gwasSumStats) blockGr <- .ctwasBlockWindows(gwasSumStats, ids) - aChr <- .ctwasChrKey(as.character(GenomicRanges::seqnames(region))) + aChr <- as.character(GenomicRanges::seqnames(region)) aPos <- GenomicRanges::start(region) - bChr <- .ctwasChrKey(as.character(GenomicRanges::seqnames(blockGr))) + bChr <- as.character(GenomicRanges::seqnames(blockGr)) bS <- GenomicRanges::start(blockGr) - bE <- GenomicRanges::end(blockGr) + # The half-open stop region_info hands cTWAS: one past the window's end. + bE <- GenomicRanges::end(blockGr) + 1L map_chr( seq_along(aPos), .ctwasBlockIdForVariant, @@ -1627,62 +1752,55 @@ mergeCtwasBoundaryRegions <- function( ) } -# The window of each LD block, taken from that block's own GWAS variants. -# -# These used to be parsed out of the region-id strings, which forced ids to -# encode coordinates ("chr1_100_200"). Each block is now an element of a -# GwasSumStats and carries its range directly, so an opaque id ("blockA") -# places just as well. A block with no variants yields an empty window and -# hosts no gene, which is the right answer: there is no GWAS signal there for -# a gene to be tested against. +# The window of each LD block (.ctwasBlockWindow()), one per block. Built from +# its parts rather than by c(): each window knows only its own chromosome, +# and combining blocks on different chromosomes would warn that their +# seqlevels share nothing. # @noRd .ctwasBlockWindows <- function(gwasSumStats, ids) { - spans <- map(gwasSumStats, .ctwasBlockSpan) - empty <- map_lgl(spans, .ctwasSpanIsEmpty) - if (all(empty)) { - # Nothing to place against; fall back to whatever the ids encode so a - # coordinate-keyed caller still behaves as before. - return(.ctwasBlockGrFromIds(ids)) - } - # unname(): c() on a NAMED list of GRanges builds a list rather than - # concatenating, and the result then fails seqnames() further down. - exec(c, !!!unname(spans)) + windows <- unname(map2(gwasSumStats, ids, .ctwasBlockWindow)) + GenomicRanges::GRanges( + map_chr(windows, .ctwasWindowSeqname), + IRanges::IRanges( + start = map_int(windows, GenomicRanges::start), + end = map_int(windows, GenomicRanges::end) + ) + ) } # @noRd -.ctwasBlockSpan <- function(gss) { - # S4 dispatch, not list flattening: `gss` is a GwasSumStats collection and - # unlist() returns the GRanges that range() below needs. - variants <- unlist(gss, use.names = FALSE) - if (length(variants) == 0L) { - return(GenomicRanges::GRanges()) - } - # A stored element spans exactly one seqname, so ignoring strand leaves a - # single range -- the block's window. - range(variants, ignore.strand = TRUE) +.ctwasWindowSeqname <- function(w) { + as.character(GenomicRanges::seqnames(w)) } +# The window of LD block `gss` (that block's GwasSumStats rows): its stored +# `region` -- the LD block it was split by, or the span of its variants as +# built -- not the span of the variants it holds now, so a gene or a SNP +# between two blocks' variants still lands in a block. A block id is only a +# name, so it gives no window. An error when the rows lie on several +# chromosomes. # @noRd -.ctwasSpanIsEmpty <- function(g) { - length(g) == 0L +.ctwasBlockWindow <- function(gss, regionId) { + window <- range(.rowRegions(gss)$region, ignore.strand = TRUE) + if (length(window) != 1L) { + chrs <- as.character(GenomicRanges::seqnames(window)) + abort(glue( + "ctwasPipeline: GwasSumStats block '{regionId}' spans multiple ", + "chromosomes ({str_flatten(chrs, ', ')})." + )) + } + window } -# 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<- +# The genes homed into region `rid`, every row on that region's LD sketch, or +# NULL when nothing landed there. # @noRd .ctwasBucketForRegion <- function(rid, combined, home, gwasSumStats) { idx <- which(home == rid) if (length(idx) == 0L) { return(NULL) } - `slot<-`( - combined[idx, ], - "ldReference", - value = ldReference(gwasSumStats[[rid]]) - ) + .withRowLdRefs(combined[idx, ], ldReference(gwasSumStats[[rid]])) } # Bucket a flat weight source into a per-region named list keyed to the block @@ -1732,8 +1850,8 @@ mergeCtwasBoundaryRegions <- function( if (length(out) == 0L) { msg <- glue( "assembleCtwasInputs: no gene placed into any LD block. ", - "Check that the weight `region`s and the gwasSumStats region_id ", - "keys share a coordinate system (e.g. 'chr22_1_1000000')." + "Check that the genes' trait positions fall inside the GWAS ", + "blocks' windows (their `region`), on the same genome build." ) abort(msg) } @@ -1757,45 +1875,6 @@ mergeCtwasBoundaryRegions <- function( if (is.null(tw)) NULL else as.character(tw$method) } -# Resolve the LIST of TWAS methods a `ctwasPipeline` run should iterate over -# (one independent cTWAS run per method -- weights are homogeneous within a -# run). - explicit `method`: exactly that one (validated present). - NULL + an -# "ensemble" method present: just "ensemble" (the pre-combined weight, the -# historical default). - NULL + a single method present: that one. - NULL + -# MULTIPLE methods, no "ensemble": ALL of them (the singular -# `.ctwasResolveMethod` errors here; the pipeline instead fans out). -# @noRd -.ctwasResolveMethods <- function(twasWeightsList, method = NULL) { - available <- unique( - if ( - methods::is(twasWeightsList, "TwasWeights") || - methods::is(twasWeightsList, "QtlFineMappingResult") - ) { - # a flat weight source - .ctwasMethodsOf(twasWeightsList) - } else { - list_c(compact(map(twasWeightsList, .ctwasMethodsOf))) - } - ) # a list of them - if (length(available) == 0L) { - abort("ctwasPipeline: weight sources carry no method entries.") - } - if (!is.null(method) && str_length(method) > 0L) { - if (!is_in(method, available)) { - msg <- glue( - "ctwasPipeline: method '{method}' not present in the weight ", - "sources (available: {str_flatten(available, ', ')})." - ) - abort(msg) - } - return(method) - } - if (is_in("ensemble", available)) { - return("ensemble") - } - available # single -> length-1 (one run); multiple -> iterate over all -} - # The single GWAS (disease) study a cTWAS run models. cTWAS solves one disease # per run (the z_snp carries a single z per SNP), so the input blocks must all # reference the same GWAS study. @@ -1985,7 +2064,8 @@ mergeCtwasBoundaryRegions <- function( # A finemap / susieAlpha table as a GRanges, its original columns preserved as # mcols. Returns the table unchanged when no row can be placed, so a payload -# that genuinely has no coordinates is not silently fabricated onto chr1. +# that genuinely has no coordinates is not silently fabricated onto chr1; when +# only some rows can be, the rest are left out of the ranges, and named. # @noRd .ctwasRangePayload <- function(df, geneCoords) { if (is.null(df) || nrow(df) == 0L) { @@ -1997,6 +2077,7 @@ mergeCtwasBoundaryRegions <- function( if (!any(placed)) { return(df) } + .ctwasWarnUnplaced(ids[!placed]) gr <- GenomicRanges::GRanges( map_chr(coord, .ctwasCoordField, field = "chrom"), IRanges::IRanges( @@ -2018,6 +2099,23 @@ mergeCtwasBoundaryRegions <- function( )[placed] } +# Rows with neither a gene coordinate nor a chrom:pos id cannot be ranged. +# @noRd +.ctwasWarnUnplaced <- function(ids) { + if (length(ids) == 0L) { + return(invisible(NULL)) + } + shown <- unique(ids) + warn(c( + glue( + "cTWAS: {length(ids)} result row(s) could not be placed on the ", + "genome and are left out of the ranged results: they have no ", + "gene coordinate and their id is not a chrom:pos variant id." + ), + set_names(utils::head(shown, 5L), rep("*", min(5L, length(shown)))) + )) +} + # @noRd .ctwasRowCoord <- function(i, ids, gc) { id <- ids[[i]] @@ -2029,7 +2127,7 @@ mergeCtwasBoundaryRegions <- function( return(NULL) } list( - chrom = withChrPrefix(as.character(parsed$chrom[[1L]])), + chrom = parsed$chrom[[1L]], start = as.integer(parsed$pos[[1L]]), end = as.integer(parsed$pos[[1L]]) ) @@ -2058,9 +2156,10 @@ mergeCtwasBoundaryRegions <- function( ) } -# region_info as a GRanges. pecotmr builds this table itself with `chr` and a -# variant-derived [start, stop], so the ranges are already there -- this only -# gives them their proper type. +# region_info as a GRanges. pecotmr builds this table itself, each block's +# window as cTWAS's half-open [start, stop), so the range ends one base before +# `stop` -- the window again (a merged region, the span of the windows it +# merged). # @noRd .ctwasRangeRegionInfo <- function(ri) { if (is.null(ri) || nrow(ri) == 0L) { @@ -2074,7 +2173,7 @@ mergeCtwasBoundaryRegions <- function( withChrPrefix(as.character(ri$chrom)), IRanges::IRanges( start = as.integer(ri$start), - end = as.integer(ri$stop) + end = as.integer(ri$stop) - 1L ) ) S4Vectors::`mcols<-`( @@ -2392,72 +2491,39 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasHarmonizeZToPanel(bind_rows(pieces), panelIds) } -# @noRd -.ctwasEntryPositions <- function(i, gss) { - gr <- gss[[i]] - list( - pos = as.integer(GenomicRanges::start(gr)), - chrs = as.character(GenomicRanges::seqnames(gr)) - ) -} - -# @noRd -.ctwasConcatInt <- function(pieces) { - if (length(pieces) == 0L) { - return(integer(0)) - } - list_c(pieces) -} - -# @noRd -.ctwasConcatChr <- function(pieces) { - if (length(pieces) == 0L) { - return(character(0)) - } - 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 +# The single-row region_info for block `regionId`: its chromosome and its +# window (.ctwasBlockWindow()), which cTWAS reads as the half-open +# [start, stop) -- so `stop` is one past the window's last base, and every +# variant of the block is assigned to it. A block with no variants, 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 + # The window is the block's own -- NOT the LD sketch's span. When many # blocks share one whole-chromosome LD payload (the common one-file-per-chr # 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). - entries <- map(seq_len(nrow(gss)), .ctwasEntryPositions, gss = gss) - pos <- .ctwasConcatInt(map(entries, "pos")) - chrs <- .ctwasConcatChr(map(entries, "chrs")) - # Emptiness is checked FIRST: `pos` and `chrs` are filled from the same - # GRanges in the same loop, so an empty block has zero chromosomes too, - # and the chromosome check below would report it as "spans multiple - # chromosomes ()" -- which is both wrong and unactionable. - if (length(pos) == 0L) { + # + # Emptiness is checked FIRST: a block with no variants has nothing for + # cTWAS to fit, and the window of one empty from the start is only a + # placeholder. + if (sum(lengths(gss)) == 0L) { msg <- glue( "ctwasPipeline: GwasSumStats block '{regionId}' has no variants ", - "to define region bounds." - ) - abort(msg) - } - chr <- unique(as.integer( - str_remove(chrs, regex("^chr", ignore_case = TRUE)) - )) - if (length(chr) != 1L) { - msg <- glue( - "ctwasPipeline: GwasSumStats block '{regionId}' spans multiple ", - "chromosomes ({str_flatten(chr, ', ')})." + "for cTWAS to fit." ) abort(msg) } + window <- .ctwasBlockWindow(gss, regionId) tibble( region_id = regionId, - chrom = chr, - start = min(pos), - stop = max(pos) + chrom = as.integer(str_remove( + as.character(GenomicRanges::seqnames(window)), + regex("^chr", ignore_case = TRUE) + )), + start = GenomicRanges::start(window), + stop = GenomicRanges::end(window) + 1L ) } @@ -2482,7 +2548,7 @@ 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(.ldRefChrom(gwasLd)), + chrom = as.integer(canonChrom(.ldRefChrom(gwasLd))), id = .ldRefMatchIds(gwasLd), pos = as.integer(GenomicRanges::start(gr)), alt = as.character(mc$A1), @@ -2560,7 +2626,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { return(NULL) } targetDf <- tibble( - chrom = as.integer(parsed$chrom), + chrom = parsed$chrom, pos = as.integer(parsed$pos), A2 = as.character(parsed$A2), A1 = as.character(parsed$A1), @@ -2935,7 +3001,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { .ctwasGenePrepared <- function(i, twasWeights, ctx) { # Polymorphic: the weight source may be a TwasWeights or a # fine-mapping result, so the payload comes from the class-aware bridge. - parts <- .rowParts(twasWeights, i) + parts <- .collectionEntry(twasWeights, i) aligned <- .ctwasAlignGeneWeights(parts, ctx$refVariants, ctx$panelSnps) if (is.null(aligned)) { return(NULL) @@ -2946,8 +3012,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ctx$fineMappingResult, meta$study, meta$context, - meta$trait, - meta$method + meta$trait ) kept <- .ctwasFilterVariants( vids = aligned$vids, @@ -3104,46 +3169,32 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { is_in(vids, as.character(regionSnps)) } -# Look up the per-(study, context, trait, method) PIP vector and the -# 95% credible-set membership / purity for one gene from the supplied -# fine-mapping result. Returns NULL when none was passed -# or no matching tuple exists. Output is a list with: +# Look up one gene's PIP vector and 95% credible-set membership / purity in +# the rescues' fine-mapping result, which .ctwasRescueSource() narrowed to the +# one method they read, so the gene's (study, context, trait) picks its fit. +# Returns NULL when no result was passed or the gene has no fit in it. Output +# is a list with: # pip : named numeric vector keyed by variant_id # csMembers : list of character vectors (one per CS at 95% coverage) # csPurity : numeric vector aligned with csMembers # @noRd -.ctwasGetFinemapAux <- function( - fmr, - studyName, - context, - trait, - method -) { +.ctwasGetFinemapAux <- function(fmr, studyName, context, trait) { if (is.null(fmr)) { return(NULL) } - cols <- .tupleColumnNames(fmr) - selectors <- c( - list(study = studyName, method = method), - compact(list( - context = if (is_in("context", cols)) context, - trait = if (is_in("trait", cols)) trait - )) + idx <- .matchTupleRows( + fmr, + list(study = studyName, context = context, trait = trait) ) - # `fineMappingResult` here is the accessor generic, not the `fmr` - # argument -- the two must not be conflated. - entry <- try_fetch( - exec(fineMappingResult, fmr, !!!selectors), - error = function(cnd) NULL - ) - if (is.null(entry)) { + if (length(idx) == 0L) { return(NULL) } - tl <- topLoci(entry, raw = TRUE) + # The stored table verbatim: every variant, no posterior projection. + tl <- .fmrPartsTopLoci(.fmrRowParts(fmr, idx[[1L]])) if (nrow(tl) == 0L) { return(NULL) } - # `pip` is part of the topLoci schema -- fineMappingRow() requires it on + # `pip` is part of the topLoci schema -- FineMappingRow() requires it on # any non-empty table, and the zero-row case returned above -- so there is # no pip-less frame to guard against here. pip <- set_names(as.numeric(tl$pip), as.character(tl$variant_id)) @@ -3652,12 +3703,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { as.character(g$study) } -# The weight method of one assembled TwasWeights record (character). -# @noRd -.ctwasMethodChr <- function(tw) { - as.character(tw$method) -} - # The block id whose window contains anchor variant `i`, or NA when unplaced. # @noRd .ctwasBlockIdForVariant <- function(i, aPos, aChr, bChr, bS, bE, ids) { diff --git a/R/ctwasWrapper.R b/R/ctwasWrapper.R index 79015153..7f89c196 100644 --- a/R/ctwasWrapper.R +++ b/R/ctwasWrapper.R @@ -43,7 +43,7 @@ # ctwas_sumstats). Routed through .ctwasInvoke so `methodArgs` reaches it -- # this was the one ctwas step CtwasOptions() could not configure. # @noRd -.ctwasEnsureZGene <- function(inputs, numThreads, extra = list()) { +.ctwasEnsureZGene <- function(inputs, threads, extra = list()) { if (!is.null(inputs$z_gene)) { return(inputs$z_gene) } @@ -52,7 +52,7 @@ list( z_snp = inputs$z_snp, weights = inputs$weights, - ncore = numThreads + ncore = threads ), extra = extra ) @@ -61,7 +61,7 @@ # assemble_region_data -> the per-region list (keyed by region_id). It does NOT # echo z_gene or return boundary genes; both are recovered separately. # @noRd -.ctwasAssembleRegionData <- function(inputs, zGene, thin, numThreads, extra) { +.ctwasAssembleRegionData <- function(inputs, zGene, thin, threads, extra) { .ctwasInvoke( ctwas::assemble_region_data, list( @@ -71,7 +71,7 @@ weights = inputs$weights, snp_map = inputs$snp_map, thin = thin, - ncore = numThreads + ncore = threads ), extra = extra ) @@ -80,7 +80,7 @@ # Boundary genes (computed internally by assemble_region_data for adjustment but # never returned) recovered via ctwas::get_boundary_genes; NULL for one region. # @noRd -.ctwasBoundaryGenes <- function(inputs, numThreads, extra) { +.ctwasBoundaryGenes <- function(inputs, threads, extra) { if (nrow(inputs$region_info) <= 1L) { return(NULL) } @@ -89,7 +89,7 @@ list( region_info = inputs$region_info, weights = inputs$weights, - ncore = numThreads + ncore = threads ), extra = extra ) @@ -105,7 +105,7 @@ niterPrefit, niter, groupPriorVarStructure, - numThreads, + threads, extra ) { .ctwasInvoke( @@ -115,7 +115,7 @@ niter_prefit = as.integer(niterPrefit), niter = as.integer(niter), group_prior_var_structure = groupPriorVarStructure, - ncore = numThreads + ncore = threads ), extra = extra ) @@ -131,7 +131,10 @@ #' values). #' #' @param estResult A list returned by \code{\link{estCtwasGroupPriors}}. -#' @param numThreads Number of cores. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the cores +#' ctwas's own \code{ncore} parallelism uses when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' core. Default \code{SerialParam()}. #' @param methodArgs Additional arguments forwarded to ctwas, built #' with \code{\link{CtwasOptions}}. Names are checked against what #' the ctwas steps accept between them. @@ -144,10 +147,12 @@ #' @export screenCtwasRegions <- function( estResult, - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) { + .assertBpparam(BPPARAM) .assertMethodOptions(methodArgs, "CtwasOptions", "methodArgs") + threads <- .bpLocalThreads(BPPARAM, "screenCtwasRegions") if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for screenCtwasRegions.") } @@ -164,7 +169,7 @@ screenCtwasRegions <- function( region_data = estResult$region_data, snp_map = estResult$snp_map, z_snp = estResult$z_snp, - ncore = as.integer(numThreads) + ncore = threads ), extra = methodArgs$expand ) @@ -177,7 +182,7 @@ screenCtwasRegions <- function( region_data = regionDataForScreen, group_prior = estResult$param$group_prior, group_prior_var = estResult$param$group_prior_var, - ncore = as.integer(numThreads) + ncore = threads ), extra = methodArgs$screen ) @@ -197,7 +202,7 @@ screenCtwasRegions <- function( .ctwasFinemapOrEmpty <- function( screenResult, maxNumSingleEffects, - numThreads, + threads, methodArgs ) { rd <- screenResult$screened_region_data @@ -216,7 +221,7 @@ screenCtwasRegions <- function( LD_format = "custom", LD_loader_fun = screenResult$LD_loader_fun, snpinfo_loader_fun = screenResult$snpinfo_loader_fun, - ncore = as.integer(numThreads) + ncore = threads ), extra = methodArgs$finemap ) @@ -271,13 +276,13 @@ screenCtwasRegions <- function( # What the pipeline itself supplies at each step's call site -- taken from the # base `list()` handed to .ctwasInvoke(), which is exactly the set that gets -# deduped away. `ncore` is the pipeline's `numThreads` everywhere. +# deduped away. `ncore` comes from the pipeline's `BPPARAM` everywhere. # @noRd .ctwasOwnedGeneZ <- function() { c( z_snp = "supplied from the data by the pipeline", weights = "supplied from the data by the pipeline", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ) } @@ -324,7 +329,7 @@ CtwasRegionDataOptions <- function(...) { weights = "supplied from the data by the pipeline", snp_map = "supplied from the data by the pipeline", thin = "CtwasPriorParam(thin =)", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasRegionDataOptions", "ctwasRegionData", @@ -354,7 +359,7 @@ CtwasEstParamOptions <- function(...) { niter_prefit = "CtwasPriorParam(niterPrefit =)", niter = "CtwasPriorParam(niter =)", group_prior_var_structure = "CtwasPriorParam(varStructure =)", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasEstParamOptions", "ctwasEstParam", @@ -377,7 +382,7 @@ CtwasScreenOptions <- function(...) { region_data = "supplied from the data by the pipeline", group_prior = "estimated by the EM step", group_prior_var = "estimated by the EM step", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasScreenOptions", "ctwasScreen", @@ -401,7 +406,7 @@ CtwasExpandOptions <- function(...) { region_data = "supplied from the data by the pipeline", snp_map = "supplied from the data by the pipeline", z_snp = "supplied from the data by the pipeline", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasExpandOptions", "ctwasExpand", @@ -430,7 +435,7 @@ CtwasFinemapOptions <- function(...) { LD_format = "fixed by the pipeline's LD loaders", LD_loader_fun = "fixed by the pipeline's LD loaders", snpinfo_loader_fun = "fixed by the pipeline's LD loaders", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasFinemapOptions", "ctwasFinemap", @@ -477,7 +482,7 @@ CtwasMergeOptions <- function(...) { LD_format = "fixed by the pipeline's LD loaders", LD_loader_fun = "fixed by the pipeline's LD loaders", snpinfo_loader_fun = "fixed by the pipeline's LD loaders", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasMergeOptions", "ctwasMerge", @@ -505,7 +510,7 @@ CtwasBoundaryGenesOptions <- function(...) { c( region_info = "supplied from the data by the pipeline", weights = "supplied from the data by the pipeline", - ncore = "the pipeline's own `numThreads`" + ncore = "the pipeline's own `BPPARAM`" ), "CtwasBoundaryGenesOptions", "ctwasBoundaryGenes", diff --git a/R/exampleData.R b/R/exampleData.R index 9c12051b..352dd2ec 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -264,8 +264,8 @@ 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{ldReference} slot -#' references the same toy PLINK1 panel. +#' phenotype by per-variant linear regression. Its LD reference is the same +#' toy PLINK1 panel. #' #' @format A \code{QtlSumStats} S4 collection with one row (study1, brain, #' ENSG_example) backed by a GRanges of 200 chr22 variants. @@ -319,8 +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{ldReference} slot references the same toy PLINK1 panel used -#' for the QTL example. +#' Its LD reference is the same toy PLINK1 panel the QTL example uses. #' #' @format A \code{GwasSumStats} S4 collection with one row (trait1) #' backed by a GRanges of 200 chr22 variants. diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index 34e15d51..cf792b0b 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -63,7 +63,7 @@ #' #' @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} +#' on inputs where \code{length(qcOptions(x)) == 0L}. \code{summaryStatsQc} #' 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 @@ -103,16 +103,21 @@ #' 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}. +#' provenance is recorded on the sumstats: \code{qcOptions()} and, +#' per row, \code{qcInfo()}. #' \item An entry that \code{summaryStatsQc(pipCutoffToSkip = ...)} screened -#' out (recorded as \code{qcInfo$entryAudit[[i]]$pipScreenSkipped}, and -#' emptied to 0 variants) is \strong{skipped}, not fit: it produces no -#' row and a message with the screen reason. An all-screened collection -#' yields a valid empty result rather than an error. +#' out (recorded in its row's \code{pipScreenSkipped} column of +#' \code{qcInfo()}, and emptied to 0 variants) is \strong{skipped}, +#' not fit: it produces no row and a message with the screen reason. +#' An all-screened collection yields a valid empty result rather than +#' an error. #' } #' #' @param data A \code{QtlDataset}, \code{MultiStudyQtlDataset}, -#' \code{QtlSumStats}, or \code{GwasSumStats}. +#' \code{QtlSumStats}, or \code{GwasSumStats}. Each row of a +#' \code{GwasSumStats} is fine-mapped as one region, so it should be an LD +#' block (load one block, or split the study with a \code{region}); a row +#' spanning more than 20 Mb, as a whole chromosome does, draws a warning. #' @param methods Method specification. Accepts either: #' \itemize{ #' \item A character vector of method tokens, e.g. @@ -131,9 +136,9 @@ #' by the pipeline (e.g. you can override \code{model_init} #' even when fitting from a susieInf chain). #' } -#' @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 +#' @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. @@ -145,14 +150,19 @@ #' (\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. +#' trait) pairs a per-context entry leaves out. In a MultiStudyQtlDataset +#' a study left with no trait selected sits out; the run is refused only +#' when no study or summary-statistics row has one. #' @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 -#' \code{traitId}. +#' \code{GRanges}. Mutually exclusive with \code{traitId}. #' @param cisWindow For QtlDataset: cis-window (bp) around each trait's genomic #' position when extracting variants. Required when \code{traitId} is -#' supplied. Mutually exclusive with \code{region}. +#' supplied. Mutually exclusive with \code{region}. For QtlSumStats: +#' optional; each selected tuple is analysed over its \code{traitPos} +#' \eqn{\pm} \code{cisWindow}, within its \code{region}, which is then +#' the window its result records. Every selected tuple needs a +#' \code{traitPos}. A MultiStudyQtlDataset applies it to each of its +#' studies, individual-level or summary-statistics, as above. #' @param jointRegions For QtlDataset with a multi-range \code{region}: #' \code{FALSE} (default) fits each range independently and merges the #' per-range results into one entry per (study, context, trait, method) -- the @@ -188,7 +198,7 @@ #' 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} +#' CV), \code{BPPARAM} 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 @@ -271,12 +281,14 @@ #' RAISS will impute. Use it when the panel cannot support the LD estimate a #' rare variant would need. #' -#' @param genotypeFilterParam Per-call overrides of the \code{QtlDataset}'s own -#' filters, built with \code{\link{GenotypeFilterParam}}. A field left unset -#' keeps the dataset's construct-time value, so -#' \code{GenotypeFilterParam(mafCutoff = 0)} pins the cutoff at zero while -#' \code{GenotypeFilterParam()} changes nothing. Applies to the -#' \code{QtlDataset} method only. +#' @param genotypeFilterParam Which variants and samples the run keeps, built +#' with \code{\link{GenotypeFilterParam}}: its \code{keepSamples} narrows +#' the dataset once, and its MAF, MAC, variance, missingness, +#' \code{keepVariants} and \code{keepIndel} settings apply to each +#' extracted block, against that block's samples. A field left unset +#' filters nothing. A \code{QtlDataset} records no filter of its own, so +#' this is the only one. \code{QtlDataset} and +#' \code{MultiStudyQtlDataset} input only. #' @param panelFilterParam LD-reference-panel filters for the summary-statistics #' and GWAS methods, built with \code{\link{PanelFilterParam}}. See #' \emph{Panel filters on the RSS path} above. @@ -288,8 +300,12 @@ #' @param dataDrivenPriorWeightsCutoff Numeric or \code{NULL}. Cutoff below #' which data-driven prior weights are zeroed; \code{NULL} disables the #' cutoff. -#' @param naAction Character. How to handle missing values in the extracted -#' phenotype/genotype data. +#' @param phenotypeFilterParam The run's phenotype QC, built with +#' \code{\link{PhenotypeFilterParam}}: how missing phenotype values are +#' handled (unset drops the affected samples; \code{"impute"} fills each +#' trait's mean; a fit cannot take \code{"keep"}) and whether outlier +#' samples are dropped. Every fit of the run, joint ones included, reads +#' its phenotypes under it. #' @param verbose Verbosity (0 silent, 1 default). Default \code{1}. #' @param residualizationParam Covariate residualization settings, built with #' \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and @@ -349,21 +365,21 @@ #' } #' @param dataType Optional assay / modality label for the phenotype the fit #' was run on (\code{"bulk_rnaseq"}, \code{"methylation"}), recorded as a -#' per-row provenance column and published by \code{\link{exportToBed}} / -#' \code{\link{exportToVcf}}. \code{NULL} (default) omits the column. It -#' cannot be derived --- the input carries the values, not what they measure. +#' per-row provenance column and published by \code{\link{writeBed}} / +#' \code{\link{writeGwasVcf}}. \code{NULL} (default) omits +#' the column. It cannot be derived --- the input carries the values, not +#' what they measure. #' @param ... Reserved for future per-method arguments. #' #' @section The genotype scale: #' Individual-level genotypes reach every fit centred and scaled to unit #' variance, so a posterior effect --- which is the prediction weight --- is #' on the standardized scale, and the published -#' \code{weight_standardized} records it. That scaling belongs to the -#' \code{QtlDataset} accessors, not to this pipeline: it is -#' \code{\link{residualizedGenotypes}} that applies it, governed by -#' \code{ResidualizationParam(scaleResiduals = )} per call with the -#' dataset's own \code{\link{scaleResiduals}} slot as the default. One -#' mechanism, one place, shared with \code{\link{twasWeightsPipeline}} and +#' \code{weight_standardized} records it. The residualization that applies +#' it (\code{\link{residualizedGenotypes}}) is governed by +#' \code{ResidualizationParam(scaleResiduals = )}, which defaults to +#' \code{TRUE}. One mechanism, one place, shared with +#' \code{\link{twasWeightsPipeline}} and #' \code{\link{colocboostPipeline}}. An RSS fit needs nothing done: its #' likelihood is written in standardized units already. #' @@ -378,10 +394,11 @@ #' @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{ldReference} for RSS-derived -#' fits. +#' Each row records the LD reference its fit used: none for +#' individual-level (QtlDataset / all-individual-level +#' MultiStudyQtlDataset) fits, the reference of the input row it was fitted +#' from for RSS-derived fits. Its \code{seqinfo()} names the genome build +#' the inputs name; inputs naming different builds are refused. #' @examples #' data(qtlDatasetExample) #' fineMappingPipeline(qtlDatasetExample, methods = "susie", cisWindow = 1e6) @@ -760,11 +777,11 @@ setGeneric("fineMappingPipeline", function(data, ...) { # Reject SumStats inputs that have not been QC'd via summaryStatsQc. # @noRd .fmAssertQcd <- function(sumstats) { - if (length(qcInfo(sumstats)) == 0L) { + if (length(qcOptions(sumstats)) == 0L) { cls <- class(sumstats)[[1L]] msg <- glue( "fineMappingPipeline: the supplied {cls} has no QC record ", - "(qcInfo is empty). Call summaryStatsQc() first and pass the ", + "(qcOptions() is empty). Call summaryStatsQc() first and pass the ", "QC-applied result." ) abort(msg) @@ -878,12 +895,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { return(NULL) } # Several rows share (study, method) when the study was split into blocks; - # the block key picks the one this lookup wants. - idx <- if (length(matched) == 1L) { - matched - } else { - matched[.rtlRangeKeys(fineMappingResult)[matched] == blockId] - } + # the block key picks the one this lookup wants. It is compared even when + # only one row matches: a cache holding one block of the study is no fit + # for any other block. + idx <- matched[which( + .rtlRangeKeys(fineMappingResult)[matched] == blockId + )] if (length(idx) == 0L) { return(NULL) } @@ -916,7 +933,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # DERIVED, never declared: it records what the accessors actually did. # `residualizedGenotypes()` scales each genotype column to unit variance # unless told otherwise -- `ResidualizationParam(scaleResiduals = FALSE)` - # per call, or the dataset's own `scaleResiduals` slot -- and an RSS fit's + # -- and an RSS fit's # likelihood is written in standardized units to begin with. mcols(x)$standardized <- rep(as.logical(standardized), length.out = n) x @@ -977,6 +994,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { } per <- .anchorVector( cfg$data, + rep(studyName(cfg$data), length(traits)), rep(ctx, length(traits)), traits, "region", @@ -985,20 +1003,28 @@ setGeneric("fineMappingPipeline", function(data, ...) { 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. +# The per-row ANALYSIS WINDOW for a set of (study, 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) { +.fmRowWindows <- function( + data, + studies, + contexts, + traits, + region, + cisWindow, + n +) { explicit <- .analysisWindowForRows(region, n) if (!is.null(explicit)) { return(explicit) } try_fetch( - .anchorVector(data, contexts, traits, "region", cisWindow), + .anchorVector(data, studies, contexts, traits, "region", cisWindow), error = function(cnd) NULL ) } @@ -1012,7 +1038,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { methods, entries, blockIds = NULL, - region = NULL, + regions = NULL, ldReference = NULL, allowEmpty = FALSE ) { @@ -1023,14 +1049,17 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) abort(msg) } - GwasFineMappingResult( + out <- GwasFineMappingResult( studyName = studies, method = methods, blockId = blockIds, entry = entries, - region = region, + region = regions$region, ldReference = ldReference ) + # The constructor counts every range it is handed as given; the run knows + # which of them its input was given and which it computed. + if (is.null(regions)) out else .withRegionColumns(out, regions) } # One QTL-side result row as an immutable record (study/context/trait/method @@ -1047,12 +1076,20 @@ setGeneric("fineMappingPipeline", function(data, ...) { ) } -# One GWAS-side result row as an immutable record (study/method/blockId + the -# FineMappingRow). blockId is provenance for the external block manifest; -# row identity comes from (study, method) plus the element's own range. +# One GWAS-side result row as an immutable record (study/method + the block +# the input row covers + the FineMappingRow). The block's id, range and +# whether that range was given are provenance; row identity comes from +# (study, method) plus the element's own range. # @noRd -.fmGwasRow <- function(studyName, method, blockId, entry) { - list(study = studyName, method = method, blockId = blockId, entry = entry) +.fmGwasRow <- function(studyName, method, block, entry) { + list( + study = studyName, + method = method, + blockId = block$id, + region = block$region, + regionGiven = block$given, + entry = entry + ) } # Effect-allele frequency vector aligned to `variantIds` from an entry's @@ -1069,32 +1106,29 @@ setGeneric("fineMappingPipeline", function(data, ...) { set_names(as.numeric(mc$AF), as.character(mc$SNP))[variantIds] } -# 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. -# -# GwasSumStats() always materializes a `blockId` column (from the entry names, -# a blockId metadata column, else coordinates), but it lives in the -# COLLECTION's mcols -- .collectionEntry() hands back the element alone, so -# 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). +# The block GWAS entry `i` covers: its name, its analysis window and whether +# that window was given. The window is the row's own `region` -- the one it +# was given, else the span of its variants as first built, before QC -- so a +# fit records the stretch its input stood for, not the narrower span of the +# variants that survived QC. # -# 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 -# "nothing was specified" case, and is less informative than the span. Only a -# coordinate-bearing key (from a manifest or an explicit vector) overrides. -# @noRd -.fmGwasBlockId <- function(data, i, gr) { - supplied <- try_fetch( - as.character(.tupleColumn(data, "blockId")[[i]]), - error = function(cnd) NULL +# The name is the row's `blockId`, carried over as it is. It lives in the +# COLLECTION's mcols -- .collectionEntry() hands back the element alone -- so +# it is read off `data`. A row with none, in a collection saved before the +# column existed, is named by its span. +# @noRd +.fmGwasBlock <- function(data, i, gr, regions) { + list( + id = .fmGwasBlockName(.tupleColumn(data, "blockId")[i], gr), + region = regions$region[i], + given = regions$regionGiven[[i]] ) - if ( - length(supplied) == 1L && - !is.na(supplied) && - !is.null(.fmBlockIdRange(supplied)) - ) { +} + +# @noRd +.fmGwasBlockName <- function(supplied, gr) { + supplied <- as.character(supplied) + if (length(supplied) == 1L && !is.na(supplied)) { return(supplied) } .fmGwasRangeKey(gr) @@ -1125,71 +1159,35 @@ setGeneric("fineMappingPipeline", function(data, ...) { } } -# The window an RSS fit covered. -# -# A GWAS block's BOUNDARY is the one positional fact not recoverable from the -# variants -- adjacent blocks leave gaps, so the realized span is narrower than -# the block (a chr22_49355984_50799822 block whose variants span -# 49363017-50598205). The boundary survives only in `blockId`, so parse it when -# it carries coordinates. Failing that the fit's own variants define the -# window: a QtlSumStats entry has no separately-requested window at all. -# @noRd -.fmBlockIdRange <- function(blockId) { - if (is.null(blockId) || length(blockId) != 1L || is.na(blockId)) { - return(NULL) - } - # .asGRegion() owns both spellings ("chr1:100-200" and "chr1_100_200") - # and keeps the seqname verbatim, so the window matches the variants' - # chromosome naming. It aborts on anything that is not coordinates -- - # the "this blockId is an opaque label" case. - try_fetch(.asGRegion(as.character(blockId)), error = function(cnd) NULL) -} - -# 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. +# Per-row block ranges for a GWAS result, and whether each was given: the +# block's range when the input row was given one, else the span of the +# entry fitted (.fmGwasBlock()). NULL when there are no rows, so the column is +# omitted. # @noRd -.fmGwasRowWindows <- function(rows) { +.fmGwasRowRegions <- function(rows) { if (length(rows) == 0L) { return(NULL) } - exec(c, !!!map(map_chr(rows, "blockId"), .fmBlockIdRange)) -} - -# @noRd -.fmRssFitWindow <- function(entry, variantIds, blockId = NULL) { - fromBlock <- .fmBlockIdRange(blockId) - if (!is.null(fromBlock)) { - return(fromBlock) - } - # isS4 guard, not just try_fetch: base::range(NULL) WARNS rather than - # erroring, so an unguarded call leaks "no non-missing arguments" noise. - rg <- if (isS4(entry)) { - try_fetch(range(entry), error = function(cnd) NULL) - } else { - NULL - } - if (methods::is(rg, "GRanges") && length(rg) > 0L) { - return(rg[1L]) - } - try_fetch(.csVariantRegion(variantIds), error = function(cnd) NULL) + list( + region = unname(unlist(.rtlBindElements(map(rows, "region")))), + regionGiven = map_lgl(rows, "regionGiven") + ) } # Fit the still-to-run RSS tokens for one GWAS region and return one row-record # per fitted token. # @noRd -.fmGwasFitRows <- function(gr, zn, st, blockId, toRun, cfg) { +.fmGwasFitRows <- function(gr, zn, st, block, toRun, cfg) { ents <- .fmFitRssBlockP( set_names(zn$z, zn$variantIds), zn, toRun, - glue("GWAS (study='{st}', region='{blockId}')"), + glue("GWAS (study='{st}', region='{block$id}')"), .fmAfByVar(gr, zn$variantIds), cfg, - region = .fmRssFitWindow(gr, zn$variantIds, blockId) + region = block$region ) - map(names(ents), .fmGwasRowFor, st = st, blockId = blockId, ents = ents) + map(names(ents), .fmGwasRowFor, st = st, block = block, ents = ents) } # All result rows for one GwasSumStats entry: cache hits + freshly-fitted @@ -1210,6 +1208,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { } return(list(rows = list(), skipped = TRUE)) } + cfg <- .fmRssRowCfg(cfg, i) zn <- .fmExtractZn( gr, glue("fineMappingPipeline(GwasSumStats): study='{st}'"), @@ -1217,10 +1216,10 @@ setGeneric("fineMappingPipeline", function(data, ...) { cutoffs = .panelCutoffs(cfg$panelFilterParam) ) # Two different things that used to be one: the key the resume cache - # matches on is always the entry's derived range, while the key stored as - # provenance is the manifest block boundary when one was supplied. + # matches on is always the entry's derived range, while the block stored + # as provenance is the one the caller gave when they gave one. rangeKey <- .fmGwasRangeKey(gr) - blockId <- .fmGwasBlockId(cfg$data, i, gr) + block <- .fmGwasBlock(cfg$data, i, gr, cfg$gwasRegions) lookups <- map( tokens, .fmGwasLookup, @@ -1232,14 +1231,28 @@ setGeneric("fineMappingPipeline", function(data, ...) { keep(lookups, .fmHasCached), .fmGwasRowFromLookup, st = st, - blockId = blockId + block = block ) toRun <- map_chr(keep(lookups, .fmNotCached), "tk") - if (length(toRun) == 0L) { - return(list(rows = cachedRows, skipped = FALSE)) + computed <- if (length(toRun) > 0L) { + .fmGwasFitRows(gr, zn, st, block, toRun, cfg) } - computed <- .fmGwasFitRows(gr, zn, st, blockId, toRun, cfg) - list(rows = c(cachedRows, computed), skipped = FALSE) + list( + rows = .recordsWithLdRef(c(cachedRows, computed), cfg$ldReference), + skipped = FALSE + ) +} + +# `cfg` for row `i`: its own LD reference, with the RSS settings resolved +# against that reference (the finite-reference size defaults to its panel's). +# @noRd +.fmRssRowCfg <- function(cfg, i) { + ldReference <- .rowLdRef(cfg$data, i) + list_assign( + cfg, + ldReference = ldReference, + susieRssParam = .fmRssArgsResolved(cfg$susieRssParam, ldReference) + ) } # The fine-mapping settings shared by every summary-statistics path: the @@ -1269,14 +1282,14 @@ setGeneric("fineMappingPipeline", function(data, ...) { } # The per-run settings the RSS / GWAS row builders all need: the common -# summary-statistics record plus the LD and RSS-control fields only the row -# builders use. The chain threads one record instead of twenty arguments, and -# every field is named deliberately -- this is not a capture of the calling -# frame. +# summary-statistics record plus the RSS-control fields only the row builders +# use. Each row adds its own LD reference, and resolves `susieRssParam` +# against it, as it is fitted (.fmRssRowCfg()). The chain threads one record +# instead of twenty arguments, and every field is named deliberately -- this +# is not a capture of the calling frame. # @noRd .fmRssRunCfg <- function( common, - ldReference, initializeWithSusieInf, methodArgs, susieRssParam @@ -1284,7 +1297,6 @@ setGeneric("fineMappingPipeline", function(data, ...) { c( common, list( - ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, susieRssParam = susieRssParam @@ -1358,7 +1370,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { glue("(study='{st}', context='{ctx}', trait='{tr}')"), .fmAfByVar(entry, zn$variantIds), cfg, - region = .fmRssFitWindow(entry, zn$variantIds) + region = .rowRegionAt(cfg$data, i) ) map(names(ents), .fmQtlRowFor, st = st, ctx = ctx, tr = tr, ents = ents) } @@ -1394,6 +1406,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { tr = tr ) toRun <- map_chr(keep(lookups, .fmNotCached), "tk") + cachedRows <- .recordsWithLdRef(cachedRows, .rowLdRef(cfg$data, i)) if (length(toRun) == 0L) { return(list(rows = cachedRows, skipped = FALSE)) } @@ -1409,8 +1422,12 @@ setGeneric("fineMappingPipeline", function(data, ...) { } return(list(rows = cachedRows, skipped = TRUE)) } + cfg <- .fmRssRowCfg(cfg, i) computed <- .fmRssFitRows(i, st, ctx, tr, toRun, cfg) - list(rows = c(cachedRows, computed), skipped = FALSE) + list( + rows = c(cachedRows, .recordsWithLdRef(computed, cfg$ldReference)), + skipped = FALSE + ) } # Concatenate two same-class fine-mapping result collections row-wise, @@ -1436,9 +1453,11 @@ setGeneric("fineMappingPipeline", function(data, ...) { #' #' @param ... Two or more \code{FineMappingResultBase} objects, or a single #' \code{list} of them. -#' @param ldReference Optional genotype panel (see -#' \code{\link{readGenotypes}}) to attach to the -#' combined collection. Default \code{NULL}. Applied when combining two or +#' @param ldReference Optional LD reference -- a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +#' \code{LdMatrix} -- that every row of the combined collection uses instead +#' of its own. Default \code{NULL}: each row keeps the reference it had, +#' and views of one source are stored once. Applied when combining two or #' more inputs; a single input is returned unchanged. #' @return A single combined fine-mapping result of the shared concrete class. #' @seealso \code{\link{combineTwasWeights}} @@ -1455,75 +1474,56 @@ combineFineMappingResults <- function(..., ldReference = NULL) { .combineTupleCollections(parts, ldReference, "combineFineMappingResults") } - -# The selector arguments are named rather than carried in `...`: an omitted -# one must still fall through to the extractor's own default, so NULL entries -# are dropped instead of forwarded. discard(is.null), not compact(): compact() -# would also drop a legitimately zero-length `contexts` / `samples`. +# Residualized phenotypes for the fits, under the run's resolved phenotype QC +# (.qtlResolvePhenotypeFilter()); NULL applies none, as the accessor does. One +# context gives its matrix, several a list keyed by context. +# @noRd .fmResidPheno <- function( x, residualizationParam, contexts = NULL, traitId = NULL, - naAction = NULL + phenotypeFilter = NULL ) { - sel <- discard( - list(contexts = contexts, traitId = traitId, naAction = naAction), - is.null - ) - exec( - residualizedPhenotypes, - !!!c( - list( - x = x, - residualizationParam = residualizationParam %||% - ResidualizationParam() - ), - sel - ) + out <- .qtlResidualizedPhenotypes( + x, + contexts, + traitId, + phenotypeFilter = phenotypeFilter %||% .qtlKeepAllPhenotypes(), + residualizationParam = residualizationParam %||% ResidualizationParam() ) + if (length(contexts) == 1L) out[[1L]] else out } +# The residualized genotypes of one analysis window -- the cis window of +# `traitId` +/- `cisWindow`, or an explicit `region` -- over `samples`, under +# the run's resolved `genotypeFilter`. No default for the filter: a call site +# that forgot it must fail rather than extract unfiltered. +# @noRd .fmResidGeno <- function( x, residualizationParam, + genotypeFilter, contexts = NULL, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL ) { - sel <- discard( - list( - contexts = contexts, - traitId = traitId, - region = region, - cisWindow = cisWindow, - samples = samples - ), - is.null - ) - # No scaling step here: `residualizedGenotypes()` already returns columns - # scaled to unit variance, governed by - # `ResidualizationParam(scaleResiduals=)` with the dataset's own slot as - # the default. Adding a second one here would have been a parallel - # mechanism for something the accessor layer owns -- and would have - # covered only the callers that happen to come through this function, - # not `colocboostPipeline`, which calls the accessor directly. - exec( - residualizedGenotypes, - !!!c( - list( - x = x, - residualizationParam = residualizationParam %||% - ResidualizationParam() - ), - sel - ) + # No scaling step here: the residualizer already returns columns scaled + # to unit variance, governed by `ResidualizationParam(scaleResiduals=)`. + # A second one here would be a parallel mechanism for something the + # residualizer owns. + .qtlResidualizedGenotypes( + x, + contexts, + window = .qtlResolveVariantRegion(x, traitId, region, cisWindow), + samples = samples, + filter = genotypeFilter, + residualizationParam = residualizationParam %||% ResidualizationParam() ) } - # Directional effect-allele (A1) frequency for the variants in a fitted # genotype block `X` (samples x variants, post-residualization and post # sample-intersection). Re-extracts the allele frequency from the dataset @@ -1538,6 +1538,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { .fmAfForX <- function( data, X, + genotypeFilter, traitId = NULL, region = NULL, cisWindow = NULL @@ -1548,23 +1549,33 @@ combineFineMappingResults <- function(..., ldReference = NULL) { if (!is(data, "QtlDataset")) { return(NULL) } - afAll <- try_fetch( - if (is.null(region)) { - af( - data, - traitId = traitId, - cisWindow = cisWindow, - samples = rownames(X) - ) - } else { - af(data, region = region, samples = rownames(X)) - }, + block <- try_fetch( + .qtlExtractBlock( + data, + window = .fmAfWindow(data, traitId, region, cisWindow), + samples = rownames(X), + filter = genotypeFilter + ), error = function(cnd) NULL ) - if (is.null(afAll) || length(afAll) == 0L) { + if (is.null(block) || length(block$af) == 0L) { return(NULL) } - unname(afAll[colnames(X)]) + unname(set_names(block$af, block$variantIds)[colnames(X)]) +} + +# The window .fmAfForX() re-extracts: the explicit `region` when given (the +# trait is then only what the block was fit for), else the trait's cis window. +# @noRd +.fmAfWindow <- function(data, traitId, region, cisWindow) { + if (is.null(region)) { + return(.qtlResolveVariantRegion( + data, + traitId = traitId, + cisWindow = cisWindow + )) + } + .qtlResolveVariantRegion(data, region = region) } .fmPostprocessOne <- function( @@ -1643,22 +1654,18 @@ combineFineMappingResults <- function(..., ldReference = NULL) { # --- Multi-region (jointRegions) helpers ------------------------------------ # Resolve the per-trait X windows from a (region, jointRegions) pair. The cis -# path (region NULL) is a single trait-derived block; an explicit `region` is -# taken literally as one joint block (jointRegions=TRUE -> concatenated -# genotypes) or one block per range (jointRegions=FALSE -> independent fits -# merged downstream). Shared by the QtlDataset / MultiStudyQtlDataset -# fineMapping & twas methods. +# path (region NULL) is a single trait-derived block; an explicit `region`, a +# GRanges, is taken literally as one joint block (jointRegions=TRUE -> +# concatenated genotypes) or one block per range (jointRegions=FALSE -> +# independent fits merged downstream). Shared by the QtlDataset / +# MultiStudyQtlDataset fineMapping & twas methods. #' @keywords internal .makeXRegions <- function(region, jointRegions) { - # Accept a "chr:start-end" string / one-row data.frame as well as a GRanges - # (a GRanges passes through unchanged), so pipeline callers need not - # pre-parse. - if (!is.null(region)) { - region <- .asGRegion(region) - } if (is.null(region)) { - list(NULL) - } else if (isTRUE(jointRegions)) { + return(list(NULL)) + } + region <- .assertRegionGRanges(region) + if (isTRUE(jointRegions)) { list(region) } else { map(seq_along(region), .fmNthRegion, region = region) @@ -1683,17 +1690,26 @@ combineFineMappingResults <- function(..., ldReference = NULL) { invisible(NULL) } +# Fine-mapping's phenotype QC: a fit cannot take a missing phenotype, so an +# unset naAction drops the affected samples and "keep" is refused. +# @noRd +.fmResolvePhenotypeFilter <- function(phenotypeFilterParam) { + .qtlResolvePhenotypeFilter( + phenotypeFilterParam, + naDefault = "drop", + naAllowed = c("drop", "impute"), + caller = "fineMappingPipeline" + ) +} + # 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. +# region + cisWindow guard and the joint-region spec. The genotype and +# phenotype filter bundles are left to the components, which resolve them +# against their own data. # @noRd -.msResolveInputs <- function(naAction, region, cisWindow, jointRegions, label) { +.msResolveInputs <- function(region, cisWindow, jointRegions, label) { .rejectRegionWithCisWindow(region, cisWindow, label) - list( - naAction = arg_match(naAction, c("drop", "impute")), - xRegions = .makeXRegions(region, jointRegions) - ) + list(xRegions = .makeXRegions(region, jointRegions)) } # Rows of a TwasWeights whose method is mr.mash and whose identity matches @@ -1963,7 +1979,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { str_c("region", seq_along(entries)) ) cvResult <- if (all(map_lgl(cvList, is.null))) NULL else cvList - fineMappingRow( + FineMappingRow( variantIds = variantIds, susieFit = susieFit, topLoci = topLoci, @@ -2108,11 +2124,10 @@ combineFineMappingResults <- function(..., ldReference = NULL) { # Whether entry `i` of a QC'd SumStats was deliberately screened out (and why), # so fineMappingPipeline can skip it gracefully instead of erroring on a # 0-variant entry. `summaryStatsQc(pipCutoffToSkip = ...)` empties a no-signal -# region and records qcInfo$entryAudit[[i]]$pipScreenSkipped (+ -# pipScreenReason); +# region and records pipScreenSkipped (+ pipScreenReason) in row i's QC audit; # an entry may also be empty for other reasons. Returns list(skipped, reason). .fmEntrySkipInfo <- function(data, i) { - ea <- try_fetch(qcInfo(data)$entryAudit[[i]], error = function(cnd) NULL) + ea <- .rowQcAudit(data, i) screened <- isTRUE(ea$pipScreenSkipped) entry <- .collectionEntry(data, i) empty <- is.null(entry) || length(entry) == 0L @@ -2361,7 +2376,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { verbose = 1, mvPrior = NULL, mvPriorCv = NULL, - numThreads = 1, + BPPARAM = SerialParam(), seed = NULL ) { if (length(tokens) == 0L) { @@ -2387,7 +2402,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { samplePartitions = samplePartition, fitFold = .fmFitFold, fitFoldCtx = cvFitCtx, - numThreads = numThreads, + BPPARAM = BPPARAM, verbose = verbose, seed = seed, # Retained so twasWeightsCv can cross-validate a SuSiE-family method: @@ -2457,7 +2472,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { if (is.null(entry) || is.null(cvResult)) { return(entry) } - fineMappingRow( + FineMappingRow( variantIds = .fmrPartsVariantIds(entry), susieFit = .fmrPartsSusieFit(entry), topLoci = .fmrPartsTopLoci(entry), @@ -2465,7 +2480,6 @@ combineFineMappingResults <- function(..., ldReference = 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 @@ -2478,7 +2492,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { samples, data, cisWindow, - residualizationParam + residualizationParam, + genotypeFilter ) { if (is.null(rg)) { .fmResidGeno( @@ -2487,7 +2502,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { traitId = traitId, cisWindow = cisWindow, samples = samples, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter ) } else { .fmResidGeno( @@ -2495,7 +2511,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { contexts = ctx, region = rg, samples = samples, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter ) } } @@ -2509,7 +2526,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { compact(map( tokens, .fmMergeTokenRow, - study = studyName, + studyName = studyName, ctx = ctx, trait = trait, blockEntries = blockEntries @@ -2518,7 +2535,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { # .fmFitXBlock with the many per-run knobs supplied from the config bundle `p`; # callers pass only the block-specific arguments (design, response, tokens, -# addSusieInf, context label, trait/PC label, allele frequencies). +# initializeWithSusieInf, context label, trait/PC label, allele frequencies). # @noRd .fmFitXBlockP <- function( X, @@ -2541,7 +2558,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { ctx, label, cvFolds = cfg$crossValidationParam$folds, - cvThreads = cfg$crossValidationParam$numThreads, + cvBpparam = cfg$crossValidationParam$BPPARAM, samplePartition = cfg$crossValidationParam$samplePartition, af = afVec, credibleSetParam = cfg$credibleSetParam, @@ -2564,7 +2581,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { rownames(Y), data = cfg$data, cisWindow = cfg$cisWindow, - residualizationParam = cfg$residualizationParam + residualizationParam = cfg$residualizationParam, + genotypeFilter = cfg$genotypeFilter ) xy <- .fmAlignXY(allX, Y, ctx, tid) X <- xy$X @@ -2581,6 +2599,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { afVec <- .fmAfForX( cfg$data, X, + genotypeFilter = cfg$genotypeFilter, traitId = tid, region = rg, cisWindow = cfg$cisWindow @@ -2623,14 +2642,14 @@ combineFineMappingResults <- function(..., ldReference = NULL) { cfg$univTokens, .fmUnivLookup, fineMappingResult = cfg$fineMappingResult, - study = cfg$study, + studyName = cfg$study, ctx = ctx, tid = tid ) cachedRows <- map( keep(lookups, .fmHasCached), .fmUnivCachedRow, - study = cfg$study, + studyName = cfg$study, ctx = ctx, tid = tid ) @@ -2642,7 +2661,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { cfg$data, contexts = ctx, traitId = tid, - naAction = cfg$naAction, + phenotypeFilter = cfg$phenotypeFilter, residualizationParam = cfg$residualizationParam ) blockEntries <- map( @@ -2670,7 +2689,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { samples, data = cfg$data, cisWindow = cfg$cisWindow, - residualizationParam = cfg$residualizationParam + residualizationParam = cfg$residualizationParam, + genotypeFilter = cfg$genotypeFilter ) common <- intersect(rownames(X), names(pcY)) if (length(common) < 2L) { @@ -2683,6 +2703,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { afVec <- .fmAfForX( cfg$data, Xb, + genotypeFilter = cfg$genotypeFilter, traitId = traits, region = rg, cisWindow = cfg$cisWindow @@ -2744,7 +2765,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { cfg$data, contexts = ctx, traitId = traits, - naAction = cfg$naAction, + phenotypeFilter = cfg$phenotypeFilter, residualizationParam = cfg$residualizationParam ) scores <- .fmTopPcScores(Yctx, cfg$nPCs) @@ -2776,11 +2797,14 @@ combineFineMappingResults <- function(..., ldReference = NULL) { # 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. +# record and lost six settings that way. `data` is the dataset narrowed to +# the filter's samples, `genotypeFilter` the run's resolved genotype filter +# (.qtlResolveFilter()), `screen` the resolved signal screen. # @noRd .fmIndividualJointCfg <- function( data, + genotypeFilter, + phenotypeFilter, contexts, traitId, cisWindow, @@ -2799,6 +2823,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { cvCfg <- .cvResolve(crossValidationParam) list( data = data, + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -2816,10 +2842,9 @@ combineFineMappingResults <- function(..., ldReference = NULL) { ) } - -# 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 -# combination. Returns `p` extended with data / screen / xRegions. +# Resolve the signal screen and the run's genotype filter, narrow the dataset +# to the filter's samples, and derive the X windows. Rejects the region + +# cisWindow combination. Returns data / screen / xRegions / genotypeFilter. # @noRd .fmQdsResolveInputs <- function( data, @@ -2830,7 +2855,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { jointRegions ) { screen <- .fmResolveScreen(signalScreenParam) - data <- .qtlApplyFilterOverrides(data, genotypeFilterParam) + genotypeFilter <- .qtlResolveFilter(genotypeFilterParam) + data <- .qtlRestrictSamples(data, genotypeFilter$keepSamples) .rejectRegionWithCisWindow( region, cisWindow, @@ -2839,7 +2865,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { list( data = data, screen = screen, - xRegions = .makeXRegions(region, jointRegions) + xRegions = .makeXRegions(region, jointRegions), + genotypeFilter = genotypeFilter ) } @@ -2925,30 +2952,6 @@ combineFineMappingResults <- function(..., ldReference = NULL) { list(tokens = remaining, methodArgs = methodArgs[remaining]) } -# 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, - .selectedTraits(traitId, studyName(data), ctx) %||% allIds - ) - } else if (!is.null(region)) { - allIds[IRanges::overlapsAny( - SummarizedExperiment::rowRanges(se), - region - )] - } else { - allIds - } - ids -} - # 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 @@ -2959,8 +2962,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { perCtxTraits <- set_names( map( useCtx, - .fmQdsTraitsForContext, - data = data, + .contextSelectedTraits, + qd = data, traitId = traitId, region = region ), @@ -3020,7 +3023,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { initializeWithSusieInf, methodArgs, nPCs, - naAction, + phenotypeFilter, perCtxTraits, studyName, univTokens, @@ -3033,7 +3036,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, nPCs = nPCs, - naAction = naAction, + phenotypeFilter = phenotypeFilter, perCtxTraits = perCtxTraits, study = studyName, univTokens = univTokens, @@ -3097,21 +3100,23 @@ combineFineMappingResults <- function(..., ldReference = NULL) { region = NULL, cisWindow = NULL ) { + rowStudy <- map_chr(rows, "study") rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { .fmBuildQtlResult( - map_chr(rows, "study"), + rowStudy, rowContext, rowTrait, map_chr(rows, "method"), map(rows, "entry"), traitPos = try_fetch( - .anchorVector(data, rowContext, rowTrait, "traitPos"), + .anchorVector(data, rowStudy, rowContext, rowTrait, "traitPos"), error = function(cnd) NULL ), region = .fmRowWindows( data, + rowStudy, rowContext, rowTrait, region, @@ -3155,7 +3160,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { jointResult, initializeWithSusieInf, nPCs, - naAction, + phenotypeFilter, usePCA ) { ctxInfo <- .fmQdsResolveContexts( @@ -3170,7 +3175,7 @@ combineFineMappingResults <- function(..., ldReference = NULL) { initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, nPCs = nPCs, - naAction = naAction, + phenotypeFilter = phenotypeFilter, perCtxTraits = ctxInfo$perCtxTraits, studyName = ctxInfo$study, univTokens = split$univTokens, @@ -3200,8 +3205,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { # 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 +# `genotypeFilterParam` is the run's genotype filter: its keepSamples narrows +# the dataset once, the rest applies per extracted block. 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 @@ -3228,13 +3233,17 @@ combineFineMappingResults <- function(..., ldReference = NULL) { seed = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, fitRetention = c("slim", "full"), dataType = NULL ) { fitRetention <- arg_match(fitRetention) - naAction <- arg_match(naAction, c("drop", "impute")) + phenotypeFilter <- .fmResolvePhenotypeFilter(phenotypeFilterParam) + build <- .inputsBuild( + list(data, region, fineMappingResult), + "fineMappingPipeline" + ) contexts <- parseContexts(contexts, data) traitId <- parseTraitIds(traitId, data) if (!is.null(seed)) { @@ -3250,6 +3259,8 @@ combineFineMappingResults <- function(..., ldReference = NULL) { ) cfg <- .fmIndividualJointCfg( data = resolved$data, + genotypeFilter = resolved$genotypeFilter, + phenotypeFilter = phenotypeFilter, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -3285,15 +3296,18 @@ combineFineMappingResults <- function(..., ldReference = NULL) { jointResult = rt$result, initializeWithSusieInf = initializeWithSusieInf, nPCs = nPCs, - naAction = naAction, + phenotypeFilter = phenotypeFilter, usePCA = usePCA ) } - .fmRecordProvenance( - out, - dataType, - "individual", - .qtlScaleResiduals(cfg$data, residualizationParam) + .withGenome( + .fmRecordProvenance( + out, + dataType, + "individual", + .qtlScaleResiduals(residualizationParam) + ), + build ) } @@ -3311,19 +3325,6 @@ setMethod( # MultiStudyQtlDataset method # ============================================================================= -# 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. -# @noRd -.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 collection always holds individual-level studies (its validity requires # one), and a joint fit spans the studies the specification selected, so when @@ -3344,24 +3345,24 @@ setMethod( 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) { + # own share, and a study left with no trait selected in its selected + # contexts -- none of its contexts, none of the traits -- sits out. + if (!.studyHasSelectedTraits(qd, cfg$contexts, cfg$traitId, cfg$region)) { return(NULL) } + s <- studyName(qd) # Every setting is named. `cfg` also carries panelFilterParam and - # susieRssParam, - # which belong to the summary-statistics path: a study's own genotypes - # are filtered by genotypeFilterParam, so those two are deliberately not - # forwarded here. A name this entry point does not accept would be an - # "unused argument" error, so the only way this can go wrong is by - # OMITTING a setting -- which test_fineMappingPipeline.R pins. + # susieRssParam, which belong to the summary-statistics path: a study's + # own genotypes are filtered by genotypeFilterParam, so those two are + # deliberately not forwarded here. A name this entry point does not + # accept would be an "unused argument" error, so the only way this can + # go wrong is by OMITTING a setting -- which test_fineMappingPipeline.R + # pins. fineMappingPipeline( data = qd, methods = m, jointSpecification = NULL, - contexts = contexts, + contexts = .selectedContexts(cfg$contexts, s), traitId = .studyTraitIdArg(cfg$traitId, s), region = cfg$region, cisWindow = cfg$cisWindow, @@ -3373,7 +3374,7 @@ setMethod( crossValidationParam = cfg$crossValidationParam, residualizationParam = cfg$residualizationParam, seed = cfg$seed, - naAction = cfg$naAction, + phenotypeFilterParam = cfg$phenotypeFilterParam, signalScreenParam = cfg$signalScreenParam, genotypeFilterParam = cfg$genotypeFilterParam, usePCA = cfg$usePCA, @@ -3400,17 +3401,18 @@ setMethod( 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. + # Summary statistics carry no genotypes: each tuple's window is in the + # input, narrowed by `cisWindow` around its trait position as on the + # QtlDataset side, 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 = if (all(keepRows)) ss else ss[which(keepRows)], methods = m, jointSpecification = NULL, contexts = NULL, traitId = NULL, + cisWindow = cfg$cisWindow, initializeWithSusieInf = cfg$initializeWithSusieInf, credibleSetParam = cfg$credibleSetParam, fineMappingResult = cfg$fineMappingResult, @@ -3424,7 +3426,6 @@ setMethod( ) } - # The joint-specification phase for the MultiStudyQtlDataset path: dispatch # whatever the spec covers, narrow the tokens the joint fits consumed, and # report whether anything is left for the per-component recursion. @@ -3553,20 +3554,25 @@ setMethod( usePCA = FALSE, nPCs = 10L, seed = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, fitRetention = c("slim", "full"), dataType = NULL ) { fitRetention <- arg_match(fitRetention) + # Resolved once here so a bad choice fails before any study runs; the + # record carries the bundle itself, as each component resolves its own. + .fmResolvePhenotypeFilter(phenotypeFilterParam) + build <- .inputsBuild( + list(data, region, fineMappingResult), + "fineMappingPipeline(MultiStudyQtlDataset)" + ) inputs <- .msResolveInputs( - naAction, region, cisWindow, jointRegions, "fineMappingPipeline(MultiStudyQtlDataset)" ) - naAction <- inputs$naAction if (!is.null(seed)) { withr::local_seed(as.integer(seed)) } @@ -3584,7 +3590,7 @@ setMethod( crossValidationParam = crossValidationParam, residualizationParam = residualizationParam, seed = seed, - naAction = naAction, + phenotypeFilterParam = phenotypeFilterParam, signalScreenParam = signalScreenParam, genotypeFilterParam = genotypeFilterParam, panelFilterParam = panelFilterParam, @@ -3596,6 +3602,7 @@ setMethod( dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, dataType = dataType ) + .msAssertTraitsSelected(data, cfg, "fineMappingPipeline") jointCfg <- .fmMsJointCfg(cfg, data, inputs$xRegions) rt <- .fmMsResolveTokens( jointSpecification, @@ -3608,20 +3615,23 @@ setMethod( rt$result, dataType, .fmMsDataSource(data), - .fmMsScaleResiduals(data, residualizationParam) + .qtlScaleResiduals(residualizationParam) ) if (rt$done) { - return(jointResult) + return(.withGenome(jointResult, build)) } - .multiStudyPipelineDriver( - data, - jointResult, - .fmPerStudy, - .fmSumStats, - list_assign(cfg, methods = rt$methods), - .rbindFineMappingResult, - QtlFineMappingResult, - "fineMappingPipeline" + .withGenome( + .multiStudyPipelineDriver( + data, + jointResult, + .fmPerStudy, + .fmSumStats, + list_assign(cfg, methods = rt$methods), + .rbindFineMappingResult, + QtlFineMappingResult, + "fineMappingPipeline" + ), + build ) } @@ -3636,6 +3646,10 @@ setMethod( list_assign( .fmIndividualJointCfg( data = data, + genotypeFilter = .qtlResolveFilter(cfg$genotypeFilterParam), + phenotypeFilter = .fmResolvePhenotypeFilter( + cfg$phenotypeFilterParam + ), contexts = cfg$contexts, traitId = cfg$traitId, cisWindow = cfg$cisWindow, @@ -3690,7 +3704,6 @@ setMethod( ) } - # The joint-specification phase for the QtlSumStats 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 @@ -4067,17 +4080,17 @@ NULL # Assemble the QtlSumStats result: build the per-tuple QtlFineMappingResult # from the collected row-records (region = entry variant span, no cis-window) -# and combine with the joint result. An all-screened collection yields a valid -# empty result rather than an error. +# and combine with the joint result, every row keeping its own LD reference. +# An all-screened collection yields a valid empty result rather than an +# error. # @noRd .fmQssAssemble <- function( data, - ldReference, rows, nSkipped, jointResult ) { - perTupleResult <- .fmQssPerTupleResult(data, rows, ldReference) + perTupleResult <- .fmQssPerTupleResult(data, rows) if (is.null(jointResult)) { if (!is.null(perTupleResult)) { return(perTupleResult) @@ -4089,7 +4102,6 @@ NULL character(0), character(0), list(), - ldReference = ldReference, allowEmpty = TRUE )) } @@ -4100,42 +4112,40 @@ NULL if (is.null(perTupleResult)) { return(jointResult) } - .rbindFineMappingResult( - perTupleResult, - jointResult, - ldReference = ldReference - ) + .rbindFineMappingResult(perTupleResult, jointResult) } # 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). +# cis-window), and its LD reference the one its entry was fitted against. # @noRd -.fmQssPerTupleResult <- function(data, rows, ldReference) { +.fmQssPerTupleResult <- function(data, rows) { if (length(rows) == 0L) { return(NULL) } + rowStudy <- map_chr(rows, "study") rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") .fmBuildQtlResult( - map_chr(rows, "study"), + rowStudy, rowContext, rowTrait, map_chr(rows, "method"), map(rows, "entry"), traitPos = try_fetch( - .anchorVector(data, rowContext, rowTrait, "traitPos"), + .anchorVector(data, rowStudy, rowContext, rowTrait, "traitPos"), error = function(cnd) NULL ), region = .fmRowWindows( data, + rowStudy, rowContext, rowTrait, NULL, NULL, length(rows) ), - ldReference = ldReference + ldReference = map(rows, "ldReference") ) } @@ -4174,16 +4184,38 @@ NULL ) } +# A QtlSumStats fine-mapping run's inputs: its data, checked for a QC record, +# and its selection parsed once, with `cisWindow` laid on the tuples selected. +# @noRd +.fmQssInputs <- function(data, contexts, traitId, cisWindow) { + .fmAssertQcd(data) + .qssSelection(data, contexts, traitId, cisWindow, "fineMappingPipeline") +} + # QtlSumStats fine-mapping worker. The resolved tokens, row selection and LD # sketch are ordinary locals, handed to the per-entry dispatch helpers as # named arguments. # @noRd +# The checks a summary-statistics fineMappingPipeline() method opens with -- +# cross-validation needs individual-level data, and the inputs must share a +# genome build -- returning that build. +# @noRd +.fmSumstatsBuild <- function(crossValidationParam, data, fineMappingResult) { + .cvRefuseOnSumstats( + crossValidationParam, + "fineMappingPipeline", + class(data)[[1L]] + ) + .inputsBuild(list(data, fineMappingResult), "fineMappingPipeline") +} + .fmPipelineQtlSumStats <- function( data, methods, initializeWithSusieInf, contexts, traitId, + cisWindow, jointSpecification, credibleSetParam, fineMappingResult, @@ -4195,18 +4227,16 @@ NULL panelFilterParam, dataType = NULL ) { - .fmAssertQcd(data) - contexts <- parseContexts(contexts, data) - traitId <- parseTraitIds(traitId, data) + inputs <- .fmQssInputs(data, contexts, traitId, cisWindow) cfgs <- .fmQssConfigs( - data = data, + data = inputs$data, credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, fitRetention = fitRetention, verbose = verbose, panelFilterParam = panelFilterParam, - contexts = contexts, - traitId = traitId, + contexts = inputs$contexts, + traitId = inputs$traitId, mrmashPrior = mrmashPrior, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff ) @@ -4218,11 +4248,11 @@ NULL cfgs$joint ) out <- .fmQssAfterJoint( - data, + inputs$data, rt = rt, cfgs = cfgs, - contexts = contexts, - traitId = traitId, + contexts = inputs$contexts, + traitId = inputs$traitId, initializeWithSusieInf = initializeWithSusieInf, susieRssParam = susieRssParam ) @@ -4249,13 +4279,11 @@ NULL return(rt$result) } sel <- .fmQssSelectRows(data = data, contexts = contexts, traitId = traitId) - ldReference <- ldReference(data) cfg <- .fmRssRunCfg( cfgs$common, - ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = rt$methodArgs, - susieRssParam = .fmRssArgsResolved(susieRssParam, ldReference) + susieRssParam = susieRssParam ) .fmQssRunRows( data, @@ -4263,7 +4291,6 @@ NULL split = .fmQssSplitTokens(rt$tokens, sel), cfg = cfg, jointCfg = cfgs$joint, - ldReference = ldReference, methodArgs = rt$methodArgs, jointResult = rt$result ) @@ -4280,7 +4307,6 @@ NULL split, cfg, jointCfg, - ldReference, methodArgs, jointResult ) { @@ -4299,7 +4325,6 @@ NULL } .fmQssAssemble( data = data, - ldReference = ldReference, rows = list_flatten(map(univOut, "rows")), nSkipped = sum(map_lgl(univOut, "skipped")), jointResult = .fmQssAutoJoint( @@ -4321,6 +4346,7 @@ setMethod( methods, contexts = NULL, traitId = NULL, + cisWindow = NULL, jointSpecification = NULL, initializeWithSusieInf = TRUE, credibleSetParam = CredibleSetParam(), @@ -4336,17 +4362,14 @@ setMethod( dataType = NULL ) { fitRetention <- arg_match(fitRetention) - .cvRefuseOnSumstats( - crossValidationParam, - "fineMappingPipeline", - "QtlSumStats" - ) - .fmPipelineQtlSumStats( + build <- .fmSumstatsBuild(crossValidationParam, data, fineMappingResult) + res <- .fmPipelineQtlSumStats( data = data, methods = methods, initializeWithSusieInf = initializeWithSusieInf, contexts = contexts, traitId = traitId, + cisWindow = cisWindow, jointSpecification = jointSpecification, credibleSetParam = credibleSetParam, fineMappingResult = fineMappingResult, @@ -4358,6 +4381,7 @@ setMethod( panelFilterParam = panelFilterParam, dataType = dataType ) + .withGenome(res, build) } ) @@ -4410,10 +4434,9 @@ setMethod( # GwasSumStats fine-mapping worker. The resolved tokens, LD sketch and # finite-sample size are ordinary locals, handed to the per-entry dispatch -# helpers as named arguments. One GwasSumStats is one LD block (the caller -# builds one collection per block when sweeping the genome); we fine-map each -# (study, method) tuple across the whole entry, with no in-pipeline block -# partitioning. +# helpers as named arguments. Each row of the GwasSumStats -- an LD block when +# it was built with a `region`, else a chromosome -- is fine-mapped as one +# region, per method. # @noRd .fmPipelineGwas <- function( data, @@ -4428,6 +4451,7 @@ setMethod( dataType = NULL ) { .fmAssertQcd(data) + .fmWarnChromosomeRows(data) norm <- .fmNormalizeMethods( methods, maxNumSingleEffects = credibleSetParam$maxNumSingleEffects %||% 10L, @@ -4435,11 +4459,9 @@ setMethod( ) .fmCheckMethodCapabilities(norm$tokens, "GwasSumStats") .fmCheckMethodArgsForInput(norm$methodArgs, "GwasSumStats") - ldReference <- ldReference(data) # Derived values are ordinary locals now, not fields grafted onto a bundle. tokens <- norm$tokens methodArgs <- norm$methodArgs - susieRssParam <- .fmRssArgsResolved(susieRssParam, ldReference) studyCol <- as.character(data$study) commonCfg <- .fmSsCommonCfg( data = data, @@ -4454,7 +4476,6 @@ setMethod( studyCol = studyCol, tokens = tokens, commonCfg = commonCfg, - ldReference = ldReference, initializeWithSusieInf = initializeWithSusieInf, methodArgs = methodArgs, susieRssParam = susieRssParam @@ -4462,6 +4483,44 @@ setMethod( .fmRecordProvenance(out, dataType, "sumstat", TRUE) } +# The widest stretch a GWAS row can span and still read as an LD block. LD +# blocks run a few megabases; a chromosome's variants span over 30 Mb even on +# chr21 and chr22. +# @noRd +.FM_MAX_BLOCK_SPAN <- 2e7 + +# Fine-mapping is meant to run one LD block at a time. A row spanning a whole +# chromosome -- what a GwasSumStats built from genome-wide statistics without +# a `region` holds -- is rarely feasible to fit as one region. Only the caller +# knows what was loaded, so it is allowed, but said. +# @noRd +.fmWarnChromosomeRows <- function(data) { + spans <- range(data) + big <- which(sum(IRanges::width(spans)) > .FM_MAX_BLOCK_SPAN) + if (length(big) == 0L) { + return(invisible(NULL)) + } + shown <- big[seq_len(min(length(big), 5L))] + warn(glue( + "fineMappingPipeline: {length(big)} GWAS row(s) span more than ", + "{.FM_MAX_BLOCK_SPAN / 1e6} Mb, as a whole chromosome does ", + "({str_flatten(.fmChromosomeRowLabels(data, spans, shown), ', ')}", + "{if (length(big) > length(shown)) ', ...' else ''}). Each is ", + "fine-mapped as one region, which is rarely feasible; build the ", + "GwasSumStats with a `region` to fine-map it block by block." + )) +} + +# "study chrom_start_end" for each of the rows `idx`. +# @noRd +.fmChromosomeRowLabels <- function(data, spans, idx) { + str_c( + as.character(data$study)[idx], + map_chr(as.list(spans)[idx], .rtlOneRangeKey), + sep = " " + ) +} + # Fine-map every row of the GWAS collection and assemble the result. # @noRd .fmGwasRunEntries <- function( @@ -4469,7 +4528,6 @@ setMethod( studyCol, tokens, commonCfg, - ldReference, initializeWithSusieInf, methodArgs, susieRssParam @@ -4479,12 +4537,14 @@ setMethod( .fmGwasEntryRows, studyCol = studyCol, tokens = tokens, - cfg = .fmRssRunCfg( - commonCfg, - ldReference = ldReference, - initializeWithSusieInf = initializeWithSusieInf, - methodArgs = methodArgs, - susieRssParam = susieRssParam + cfg = list_assign( + .fmRssRunCfg( + commonCfg, + initializeWithSusieInf = initializeWithSusieInf, + methodArgs = methodArgs, + susieRssParam = susieRssParam + ), + gwasRegions = .rowRegions(data) ) ) rows <- list_flatten(map(entryOut, "rows")) @@ -4496,11 +4556,10 @@ setMethod( map_chr(rows, "method"), map(rows, "entry"), blockIds = map_chr(rows, "blockId"), - # The block BOUNDARY where blockId carries one, else the entry's span: - # the same window .fmRssFitWindow() gives the per-row grange columns, - # so the two cannot disagree. - region = .fmGwasRowWindows(rows), - ldReference = ldReference, + # The same window each fit was given (.fmGwasBlock()), so the stored + # region and the fit's own cannot disagree. + regions = .fmGwasRowRegions(rows), + ldReference = map(rows, "ldReference"), allowEmpty = (nSkipped > 0L || nrow(data) == 0L) ) } @@ -4525,12 +4584,8 @@ setMethod( dataType = NULL ) { fitRetention <- arg_match(fitRetention) - .cvRefuseOnSumstats( - crossValidationParam, - "fineMappingPipeline", - "GwasSumStats" - ) - .fmPipelineGwas( + build <- .fmSumstatsBuild(crossValidationParam, data, fineMappingResult) + res <- .fmPipelineGwas( data = data, methods = methods, initializeWithSusieInf = initializeWithSusieInf, @@ -4542,6 +4597,7 @@ setMethod( panelFilterParam = panelFilterParam, dataType = dataType ) + .withGenome(res, build) } ) @@ -4578,13 +4634,13 @@ setMethod( } # @noRd -.fmGwasRowFor <- function(tk, st, blockId, ents) { - .fmGwasRow(st, tk, blockId, ents[[tk]]) +.fmGwasRowFor <- function(tk, st, block, ents) { + .fmGwasRow(st, tk, block, ents[[tk]]) } # @noRd -.fmGwasRowFromLookup <- function(l, st, blockId) { - .fmGwasRow(st, l$tk, blockId, l$cached) +.fmGwasRowFromLookup <- function(l, st, block) { + .fmGwasRow(st, l$tk, block, l$cached) } # @noRd @@ -4703,8 +4759,9 @@ setMethod( # postprocessFinemappingFits() -- so changing them needs a refit while a # stored fit can be re-post-processed under a different coverage. # -# `addSusieInf` is a standalone argument, not a bundle field: it selects a -# chained initialisation between methods rather than describing credible sets. +# `initializeWithSusieInf` is a standalone argument, not a bundle field: it +# selects a chained initialisation between methods rather than describing +# credible sets. # # `fitRetention` is a plain arg_match() enum on each pipeline, not a bundle: # see colocPipeline(), crossValidation() and fineMappingPipeline(). @@ -4967,10 +5024,12 @@ setValidity("CredibleSetParam", function(object) { #' \code{NULL} (the default) leaves the engine's own default in place. #' @return \code{CredibleSetParam} returns a \code{CredibleSetParam} #' object, a \code{\link{MethodParam}}. Each accessor returns that -#' setting's value; each replacement form returns a modified copy. -#' \code{maxNumSingleEffects} and \code{maxNumSingleEffectsGreedy} have -#' no replacement form: they are seeded onto the fitting tokens, so -#' changing one needs a refit rather than a re-summary. +#' setting's value. Change a setting with \code{x$ <- value} (the +#' field for \code{csCoverage()} is \code{coverage}), which returns a +#' modified copy; \code{maxNumSingleEffects} and +#' \code{maxNumSingleEffectsGreedy} cannot be changed that way: they are +#' seeded onto the fitting tokens, so changing one needs a refit rather +#' than a re-summary. #' @examples #' CredibleSetParam(coverage = 0.9, includeAllCs = TRUE) #' @export @@ -5001,82 +5060,30 @@ 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 diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index 793f7681..8824150d 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -22,13 +22,20 @@ NULL #' @title Fine-Mapping Row #' @description One row's worth of fine-mapping: the variants and the stored -#' fit. Build one with \code{\link{fineMappingRow}} and pass a list of them +#' fit. Build one with \code{\link{FineMappingRow}} and pass a list of them #' as a collection's \code{entry} argument. #' @slot variants A \code{GRanges} of the fit's variants whose metadata #' columns are the per-variant \code{topLoci} values. #' @slot susieFit The stored fine-mapping fit, or \code{NULL}. #' @slot cvResult Cross-validation payload, or \code{NULL}. -#' @seealso \code{\link{fineMappingRow}}, +#' @slot fitVariants The ids of the variants the stored fit was made with, in +#' the fit's own order, recorded when the row is built; empty for a row with +#' no fit. A row narrowed to fewer variants keeps them, which is how reading +#' the fit can tell it describes more variants than the row now holds. +#' @section Coercion: \code{as(x, "GRanges")} gives the row's variants with +#' their per-variant \code{topLoci} columns: the element a collection +#' stores for it. +#' @seealso \code{\link{FineMappingRow}}, #' \code{\linkS4class{TwasWeightsRow}} #' @export setClass( @@ -36,9 +43,10 @@ setClass( representation( variants = "GRanges", susieFit = "ANY", - cvResult = "ANY" + cvResult = "ANY", + fitVariants = "character" ), - prototype(susieFit = NULL, cvResult = NULL) + prototype(susieFit = NULL, cvResult = NULL, fitVariants = character(0)) ) #' @importFrom checkmate makeAssertCollection assertList @@ -78,19 +86,19 @@ methods::setValidity("FineMappingRow", function(object) { #' \code{variantIds}. #' @param cvResult Optional cross-validation payload. #' @return A \code{\linkS4class{FineMappingRow}}. -#' @seealso \code{\link{twasWeightsRow}} +#' @seealso \code{\link{TwasWeightsRow}} #' @examples #' tl <- data.frame( #' variant_id = c("chr1:100:A:G", "chr1:200:C:T"), #' pip = c(0.9, 0.1) #' ) -#' row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) +#' row <- FineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) #' QtlFineMappingResult( #' studyName = "s1", context = "c1", trait = "g1", method = "susie", #' entry = list(row) #' ) #' @export -fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { +FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { vids <- as.character(variantIds) bare <- .variantIdsToGRanges(vids, "variantIds") tl <- as_tibble(topLoci) @@ -113,14 +121,14 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { .fmRowCheckIdOrder(vids, as.character(tl$variant_id)) } gr <- .fmRowAttachPayload(bare, tl) - obj <- new( + fitted <- length(susieFit) > 0L || !is.null(cvResult) + new( "FineMappingRow", variants = gr, susieFit = susieFit, - cvResult = cvResult + cvResult = cvResult, + fitVariants = if (fitted) .grVariantIds(bare) else character(0) ) - validObject(obj) - obj } # The row a cross-validation-only fit leaves (CrossValidationParam(fitFullData = @@ -129,7 +137,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # a resume cache only reuses them for another cross-validation-only run. # @noRd .fmCvOnlyRow <- function(cvResult = NULL) { - fineMappingRow( + FineMappingRow( variantIds = character(0), susieFit = NULL, topLoci = tibble(), @@ -187,7 +195,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { (!is.null(fit$fitted_wc2) && !is.null(fit$alpha))) } -# Chromosome of the fit's variants (matches topLoci's `chrom`, no "chr"). +# Chromosome of the fit's variants, as topLoci's `chrom` spells it. # @noRd .fsusieChrom <- function(fit) { vid <- names(fit$csd_X) @@ -857,28 +865,61 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { !(inCs & !is.na(pur) & pur < minPurity) } -# Project a posterior-view data.frame to GRanges (empty GRanges when empty). +# A tabular view handed back as a Bioconductor DataFrame. The views assemble +# tibbles (dplyr is how they are built); a table attached to an S4 result is +# a DataFrame, as mcols() and colData() are, so the conversion happens once, +# at the accessor. check.names = FALSE keeps names such as PP.H4.abf. +# @noRd +.asViewDataFrame <- function(tbl) { + S4Vectors::DataFrame(tbl, check.names = FALSE) +} + +# A per-variant table as ranges: one width-1 range per row at the position its +# `variant_id` names, every column kept as mcols. topLoci(), credibleSets(), +# marginalEffects() and lbf() all convert through here once their rows are +# stacked, so the aggregate form is a GRanges as well as the single-entry +# one, and either narrows with subsetByOverlaps(). # @noRd -.fmeTopLociGRanges <- function(out) { +.variantTableGRanges <- function(out) { if (is.null(out)) { return(GenomicRanges::GRanges()) } - # Keep the column schema when there are no retained variants, so an - # empty result is inspectable the same way a populated one is. if (nrow(out) == 0L) { - return(S4Vectors::`mcols<-`( - GenomicRanges::GRanges(), - value = S4Vectors::DataFrame(out) - )) + return(.emptyTableGRanges(out)) } parsed <- parseVariantId(out$variant_id) gr <- GenomicRanges::GRanges( - seqnames = str_c("chr", parsed$chrom), + seqnames = parsed$chrom, ranges = IRanges::IRanges(start = parsed$pos, width = 1L) ) S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(out)) } +# An fSuSiE credible-band table as ranges: one width-1 range per grid point, +# on the chromosome and at the position its `chrom` / `pos` columns give -- +# the same placement fsusieAffectedRegions() uses for its regions. +# @noRd +.bandTableGRanges <- function(out) { + if (nrow(out) == 0L) { + return(.emptyTableGRanges(out)) + } + gr <- GenomicRanges::GRanges( + seqnames = out$chrom, + ranges = IRanges::IRanges(start = as.integer(out$pos), width = 1L) + ) + S4Vectors::`mcols<-`(gr, value = S4Vectors::DataFrame(out)) +} + +# An empty table as an empty GRanges that keeps the column schema, so an +# empty result is inspectable the same way a populated one is. +# @noRd +.emptyTableGRanges <- function(out) { + S4Vectors::`mcols<-`( + GenomicRanges::GRanges(), + value = S4Vectors::DataFrame(out) + ) +} + # Match the entry's variants to `keepVariants` by (chrom, pos, allele) so a # chr-prefix / separator difference does not read as no-overlap. PIP / LBF are @@ -897,6 +938,21 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { sort(m$idxA) } +# Where each of `common` sits among the variables `fitted` the fit was made +# with. An element replaced through `[[<-` can hold a variant its fit never +# had, which leaves no column to restrict to. +# @noRd +.adjustPipsFitIdx <- function(common, fitted) { + idx <- .fitColumnOf(common, fitted) + if (anyNA(idx)) { + abort(glue( + "adjustPips: {sum(is.na(idx))} of the row's variants are not ", + "among the {length(fitted)} its fit was made with." + )) + } + idx +} + # Restrict the SuSiE fit to `keepIdx` and renormalize every single-effect # posterior over the retained variants. # @noRd @@ -1582,9 +1638,15 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { #' @noRd setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { vids <- variantIds(x) - keepIdx <- .adjustPipsKeepIdx(vids, keepVariants) - common <- vids[keepIdx] - fit <- .adjustPipsSubsetFit(susieFit(x), keepIdx, length(vids)) + common <- vids[.adjustPipsKeepIdx(vids, keepVariants)] + # The fit's columns are its own variables, which a row narrowed since + # holds only some of, so the kept variants are found in it by id. + fitted <- .partsFitIds(x) + fit <- .adjustPipsSubsetFit( + susieFit(x), + .adjustPipsFitIdx(common, fitted), + length(fitted) + ) newTopLoci <- .adjustPipsRebuildTopLoci( .fmeTopLociFromElement(variants(x)), fit, @@ -1592,7 +1654,7 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { ) # cvResult is sample-indexed (partition + held-out predictions), not # variant-indexed, so it carries through a variant-subsetting unchanged. - fineMappingRow( + FineMappingRow( variantIds = common, susieFit = fit, topLoci = newTopLoci, @@ -1618,6 +1680,9 @@ setMethod("susieFit", "FineMappingRow", function(x) x@susieFit) #' @export setMethod("cvResult", "FineMappingRow", function(x) x@cvResult) +# @noRd +.fmRowFitVariants <- function(x) x@fitVariants + #' @rdname show-methods #' @export setMethod("show", "FineMappingRow", function(object) { @@ -1647,3 +1712,10 @@ setGeneric("variants", function(x, ...) standardGeneric("variants")) # @noRd setMethod("variants", "FineMappingRow", function(x) x@variants) + +#' @rdname FineMappingRow-class +#' @name coerce,FineMappingRow,GRanges-method +#' @aliases coerce,FineMappingRow,GRanges-method +#' @usage NULL +#' @exportMethod coerce +setAs("FineMappingRow", "GRanges", function(from) variants(from)) diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 5898fa86..784930ca 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -297,8 +297,8 @@ fitSusieInfThenSusie <- function( #' @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}. -#' @param region Optional \code{"chr:start-end"} string naming the region the -#' fits cover; recorded on the result. Default \code{NULL}. +#' @param region Optional \code{GRanges}: the window the fits cover, recorded +#' on the result. Default \code{NULL}. #' @param priorEffTol Numeric (length 1). Effects whose prior variance #' \code{V} is at or below this tolerance are dropped as unconverged before #' the credible sets are read. Default \code{1e-9}. @@ -624,7 +624,7 @@ postprocessFinemappingFit.susiF <- function( trim, priorEffTol ) { - fmEntry <- fineMappingRow( + fmEntry <- FineMappingRow( variantIds = variantNames, susieFit = .ppStoredFit( csTables, @@ -1091,7 +1091,10 @@ computeCsTable <- function( # order; errors if any fit variant is absent (a missing one would misalign the # 1..p credible-set indices with a shrunken genotype matrix). .csGenotypesForFit <- function(qtlDataset, variantIds) { - geno <- genotypes(qtlDataset, region = .csVariantRegion(variantIds)) + geno <- .qtlExtractBlock( + qtlDataset, + window = .csVariantRegion(variantIds) + )$geno absent <- setdiff(variantIds, colnames(geno)) if (length(absent) > 0L) { abort(glue( @@ -1108,7 +1111,10 @@ setMethod( "computeCsCorrelation", signature(x = "FineMappingResultBase", ldSource = "SumStatsBase"), function(x, ldSource) { - .rowCsCorrelationSumstats(.asFmRowPayload(x), ldSource) + .rowCsCorrelationSumstats( + .fitCoverageChecked(.asFmRowPayload(x), "computeCsCorrelation()"), + ldSource + ) } ) @@ -1119,16 +1125,12 @@ setMethod( if (.csCountBelowTwo(fit)) { return(NULL) } - ldReference <- ldReference(ldSource) - if (is.null(ldReference)) { - abort(glue( - "computeCsCorrelation(): the summary-statistics ldSource ", - "carries no LD reference to derive the correlation from." - )) - } + ldReference <- .csSumstatsLdRef(ldSource) # onMissing = "error": every fit variant must be in the panel, else the - # 1..p sets$cs indices would misalign with a shrunken LD matrix. - ids <- .fmrPartsVariantIds(parts) + # 1..p sets$cs indices would misalign with a shrunken LD matrix. The + # indices are the fit's, so the ids are too, even for a row narrowed + # since. + ids <- .partsFitIds(parts) label <- "computeCsCorrelation" if (inherits(fit, "susiF")) { return(.fsusieCsCorrelationLd(fit$cs, ldReference, ids, label)) @@ -1145,6 +1147,31 @@ setMethod( } } +# The one LD reference a summary-statistics ldSource offers. Its rows can sit +# on different references, and nothing in the fit says which of them it was +# computed against, so a collection with several is refused rather than read +# from whichever comes first. +# @noRd +.csSumstatsLdRef <- function(ldSource) { + refs <- ldReference(ldSource) + if (length(refs) == 0L) { + abort(glue( + "computeCsCorrelation(): the summary-statistics ldSource ", + "carries no LD reference to derive the correlation from." + )) + } + if (length(refs) > 1L) { + abort(c( + glue( + "computeCsCorrelation(): the summary-statistics ldSource's ", + "rows use {length(refs)} different LD references." + ), + i = "Pass the row the fit came from, e.g. `ldSource[i]`." + )) + } + refs[[1L]] +} + # Individual-level LD source: genotypes -> aligned X. susie fits derive the LD # via get_cs_correlation(X = ); fSuSiE fits (class "susiF") via cal_cor_cs(). #' @rdname computeCsCorrelation @@ -1152,7 +1179,10 @@ setMethod( "computeCsCorrelation", signature(x = "FineMappingResultBase", ldSource = "QtlDataset"), function(x, ldSource) { - .rowCsCorrelationGeno(.asFmRowPayload(x), ldSource) + .rowCsCorrelationGeno( + .fitCoverageChecked(.asFmRowPayload(x), "computeCsCorrelation()"), + ldSource + ) } ) @@ -1163,7 +1193,7 @@ setMethod( if (.csCountBelowTwo(fit)) { return(NULL) } - geno <- .csGenotypesForFit(ldSource, .fmrPartsVariantIds(parts)) + geno <- .csGenotypesForFit(ldSource, .partsFitIds(parts)) if (inherits(fit, "susiF")) { if (!requireNamespace("fsusieR", quietly = TRUE)) { abort(glue( @@ -1548,7 +1578,8 @@ setMethod( #' carries no sample count: \code{n} is left \code{NA} for the per-variant #' \code{n} argument to fill. #' @param otherQuantities Optional list. Default is NULL. -#' @param region Optional \code{"chr:start-end"} string. Default is NULL. +#' @param region Optional \code{GRanges}: the window the fit covers, whose +#' bounds the table records. Default is NULL. #' @param conditionIdx Integer or \code{NULL}. Index of the conditioned effect #' (per-condition output); \code{NULL} for the unconditioned fit. #' @param credibleSetParam How credible sets are built and reported, built with @@ -2308,35 +2339,19 @@ buildTopLoci <- function( ) } -.parseGrange <- function(regionStr) { - # Every in-package source of a window is a GRanges (the pipeline's - # `region`, an X block's own range); only the documented user-facing form - # is a string. Normalize here so no caller has to. - if (methods::is(regionStr, "GRanges")) { - if (length(regionStr) == 0L) { - return(c(start = NA_integer_, end = NA_integer_)) - } - return(c( - start = as.integer(GenomicRanges::start(regionStr)[[1L]]), - end = as.integer(GenomicRanges::end(regionStr)[[1L]]) - )) - } - if ( - is.null(regionStr) || - length(regionStr) == 0L || - is.na(regionStr) || - str_length(as.character(regionStr)) == 0L - ) { +# The bounds the top-loci table records for the window the fits cover: a +# GRanges, as every source of one is (the pipeline's `region`, an X block's +# own range, a caller's), or NA bounds when there is none. +# @noRd +.parseGrange <- function(region) { + if (is.null(region) || length(region) == 0L) { return(c(start = NA_integer_, end = NA_integer_)) } - pr <- try_fetch( - parseRegion(as.character(regionStr)), - error = function(cnd) NULL + .assertRegionGRanges(region) + c( + start = as.integer(GenomicRanges::start(region)[[1L]]), + end = as.integer(GenomicRanges::end(region)[[1L]]) ) - if (is.null(pr) || !is.data.frame(pr)) { - return(c(start = NA_integer_, end = NA_integer_)) - } - c(start = as.integer(pr$start), end = as.integer(pr$end)) } trimFinemappingFit <- function(fit, effectIdx, method, csTables) { @@ -2918,10 +2933,8 @@ MvsusieMixturePriorOptions <- function(...) { #' ready to pass as \code{prior_variance} to \code{\link{fitMvsusie}} or #' \code{\link{fitMvsusieRss}}. #' @examples -#' \donttest{ #' # Canonical uniform mixture over two named conditions. #' buildMvsusieMixturePrior(conditionNames = c("brain", "blood")) -#' } #' @importFrom checkmate assertCount #' @export buildMvsusieMixturePrior <- function( @@ -4031,7 +4044,9 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { #' #' 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. +#' fine-mapping entry is attached. As \code{\link{susieFit}} does, it warns +#' (condition class \code{pecotmrFitCoverage}) when the entry holds fewer +#' variants than its fit was made with. #' #' @param conData List. The method-layer entry from a finemapping pipeline #' result, expected to carry \code{$finemappingEntry} as a @@ -4055,6 +4070,7 @@ susieResult <- function(conData) { if (!is(fm, "FineMappingRow") && !is(fm, "FineMappingResultBase")) { return(NULL) } + fm <- .fitCoverageChecked(.asFmRowPayload(fm), "susieResult()") trimmed <- .fmrPartsSusieFit(fm) if (length(trimmed) == 0) { return(NULL) @@ -4067,7 +4083,7 @@ susieResult <- function(conData) { #' This function extracts and processes information for each Credible Set (CS) #' from finemapping results, typically obtained from a finemapping RDS file. #' -#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' @param fmRow A \code{\link{FineMappingRow}}, or a single-row #' fine-mapping collection as returned by #' \code{\link{fineMappingResult}}, carrying the SuSiE fit and #' variant ids. @@ -4113,7 +4129,7 @@ susieResult <- function(conData) { #' fit <- list(pip = c(0.1, 0.7, 0.2), sets = list(cs = list(L_1 = c(1, 2)))) #' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2), #' z = c(1.0, 3.5, -0.5)) -#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +#' fe <- FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) #' # A single credible set has no between-CS correlation (cs_corr_* are NA), so #' # the ldSource is not consulted here. #' extractCsInfo(fe, csNames = "L_1", topLociTable = tl, @@ -4123,9 +4139,11 @@ susieResult <- function(conData) { #' @export extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { assertCharacter(csNames, any.missing = FALSE) - fm <- fmRow + # The credible sets index the fit's own variables, so they are named by + # the ids the fit was made with rather than the ones the row holds now. + fm <- .fitCoverageChecked(.asFmRowPayload(fmRow), "extractCsInfo()") trimmed <- .fmrPartsSusieFit(fm) - variantNames <- .fmrPartsVariantIds(fm) + variantNames <- .partsFitIds(fm) csCorr <- .rowCsCorrelation(fm, ldSource) rows <- map( seq_along(csNames), @@ -4144,7 +4162,7 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' Posterior Inclusion Probability (PIP) from finemapping results, typically #' used when no Credible Sets (CS) are identified in the analysis. #' -#' @param fmRow A \code{\link{fineMappingRow}}, or a single-row +#' @param fmRow A \code{\link{FineMappingRow}}, or a single-row #' fine-mapping collection as returned by #' \code{\link{fineMappingResult}}, carrying the SuSiE fit and #' variant ids. @@ -4180,15 +4198,15 @@ extractCsInfo <- function(fmRow, csNames, topLociTable, ldSource) { #' vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") #' fit <- list(pip = c(0.1, 0.7, 0.2)) #' tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2)) -#' fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +#' fe <- FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) #' extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) #' #' @importFrom checkmate assertClass #' @export extractTopPipInfo <- function(fmRow, sumstats) { - fm <- fmRow + fm <- .fitCoverageChecked(.asFmRowPayload(fmRow), "extractTopPipInfo()") trimmed <- .fmrPartsSusieFit(fm) - variantNames <- .fmrPartsVariantIds(fm) + variantNames <- .partsFitIds(fm) # Find the variant with the highest PIP topPipIndex <- which.max(trimmed$pip) topPip <- trimmed$pip[topPipIndex] @@ -4603,7 +4621,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { ctx, tid, cvFolds = 0, - cvThreads = 1, + cvBpparam = SerialParam(), samplePartition = NULL, af = NULL, fitRetention = "slim", @@ -4633,7 +4651,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { coverage = credibleSetParam$coverage, methodArgs = methodArgs, cvFolds = cvFolds, - cvThreads = cvThreads, + cvBpparam = cvBpparam, samplePartition = samplePartition, seed = seed, verbose = verbose, @@ -4747,7 +4765,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { coverage, methodArgs, cvFolds, - cvThreads, + cvBpparam, samplePartition, seed, verbose, @@ -4773,7 +4791,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { samplePartition = samplePartition, coverage = coverage, verbose = verbose, - numThreads = cvThreads, + BPPARAM = cvBpparam, seed = seed ) set_names( @@ -5101,7 +5119,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # A row is immutable: rebuild it with the amended fit rather than # assigning into it. The variants and topLoci are unchanged, so this # round-trips them through the same builder the caller used. - fineMappingRow( + FineMappingRow( variantIds = variantIds(ent), susieFit = sf, topLoci = .fmrPartsTopLoci(ent), @@ -5862,7 +5880,7 @@ krigingOutlierQc <- function( fit = fit ) GenomicRanges::GRanges( - seqnames = str_c("chr", str_remove(chrom, "^chr")), + seqnames = chrom, ranges = IRanges::IRanges( start = as.integer(reg$Start), end = as.integer(reg$End) diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 0fdb4fea..53606e51 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -55,7 +55,7 @@ setMethod( pvar = NULL, psam = NULL, ldMeta = NULL, - region = NULL, + block = NULL, genoMeta = NULL, chroms = NULL, format = NULL, @@ -74,7 +74,7 @@ setMethod( pvar = pvar, psam = psam, ldMeta = ldMeta, - region = region, + block = block, genoMeta = genoMeta, chroms = chroms, format = format, @@ -98,7 +98,7 @@ setMethod( pvar = NULL, psam = NULL, ldMeta = NULL, - region = NULL, + block = NULL, genoMeta = NULL, chroms = NULL, format = NULL, @@ -112,7 +112,7 @@ setMethod( pvar = pvar, psam = psam, ldMeta = ldMeta, - region = region + block = block ) sources <- .ghResolveSources( path = NULL, @@ -134,7 +134,7 @@ setMethod( plink2Triplet = .genotypeExperiment( .genotypeHandleFromPlink2Triplet(pgen, pvar, psam) ), - ldMeta = .ghLdPathToPanel(.ghResolveLdPath(ldMeta, region), vcfArgs), + ldMeta = .ghLdPathToPanel(.ghResolveLdPath(ldMeta, block), vcfArgs), genoMeta = .chromMetaPanel(genoMeta, chroms, format) ) } @@ -255,7 +255,7 @@ setMethod( # readPvar returns: chrom, id, pos, A2 (REF), A1 (ALT) -- pecotmr convention snpInfo <- tibble( SNP = vi$id, - CHR = as.character(vi$chrom), + CHR = withChrPrefix(vi$chrom), BP = as.integer(vi$pos), A1 = vi$A1, A2 = vi$A2 @@ -409,6 +409,118 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { ) } +# ============================================================================= +# Panels saved by an earlier version +# ----------------------------------------------------------------------------- +# A panel built today records where its genotypes come from +# (metadata$genotypeSource), and one over a VCF, GDS or PLINK1 file reads +# through that format's own backend. A panel saved before either reads +# through a GenotypeHandle's GhSeed, in a format a handle may no longer read, +# and a stochastic sketch saved then lacks the real sample count and allele +# frequencies it is read with today (.withLdProjection()). Such a panel is +# read again from its files, as readGenotypes() reads them, and cut to the +# variants and samples it held. Only the files' variant and sample lists and +# a sketch's sidecar are read, never genotypes, and nothing is written. +# ============================================================================= + +# `panel` as a panel built today: read again from its files when it was +# saved before the changes above, else `panel` itself -- as for one that +# reads through no handle (a VCF, GDS or PLINK1 panel built since, or one +# held in memory). A bare GenotypeHandle, which an LD reference was before +# it was a panel, is taken as the panel over it. +# @noRd +.updatePanel <- function(panel) { + panel <- .asLdRef(panel) + handle <- .ldRefHandle(panel) + if (is.null(handle)) { + return(panel) + } + source <- .genotypeSourceRecord(handle) + recorded <- !is.null(S4Vectors::metadata(panel)$genotypeSource) + if (recorded && !is_in(source$format, .DOSAGE_PANEL_FORMATS)) { + return(panel) + } + .rereadPanel(panel, source) +} + +# `panel` read again from `source`, the record of where its genotypes come +# from, and cut to the variants and samples it held, keeping its sample data +# (a QTL dataset's genotype covariates). Variants are matched on position +# and alleles, which identify them however their names were normalized when +# the panel was saved. A `pecotmrUnreadablePanel` error when the files +# cannot be read or no longer hold them all. +# @noRd +#' @importFrom rlang try_fetch +.rereadPanel <- function(panel, source) { + fresh <- try_fetch( + .readSourcePanel(source), + error = function(cnd) { + .abortUnreadablePanel(source, "they cannot be read", cnd) + } + ) + rows <- match( + .grVariantIds(SummarizedExperiment::rowRanges(panel)), + .grVariantIds(SummarizedExperiment::rowRanges(fresh)) + ) + cols <- match(colnames(panel), colnames(fresh)) + if (length(rows) != nrow(panel) || anyNA(rows) || anyNA(cols)) { + .abortUnreadablePanel( + source, + "they no longer hold every variant and sample it did" + ) + } + SummarizedExperiment::`colData<-`( + .panelCut(fresh, rows, cols), + value = SummarizedExperiment::colData(panel) + ) +} + +# The panel today's readers build over a genotype source: its per-chromosome +# files' panels stacked when it has them, else its one file's. A bundled +# example's portable path resolves under the installed package. +# @noRd +.readSourcePanel <- function(source) { + if (length(source$chromPaths) > 0L) { + return(.chromMetaPanel( + map_chr(source$chromPaths, .resolveGenotypeResourcePath), + format = source$format + )) + } + .readGenotypePanel( + .resolveGenotypeResourcePath(source$path), + format = source$format + ) +} + +# `panel` cut to rows `rows` and columns `cols`, each cut only when it does +# not keep everything in order. +# @noRd +.panelCut <- function(panel, rows, cols) { + if (!identical(rows, seq_len(nrow(panel)))) { + panel <- .ldRefSubset(panel, rows) + } + if (identical(cols, seq_len(ncol(panel)))) { + return(panel) + } + panel[, cols] +} + +# @noRd +.abortUnreadablePanel <- function(source, why, parent = NULL) { + abort( + c( + glue( + "A {source$format} genotype panel saved by an earlier pecotmr ", + "has to be read again from its files at {source$path}, and ", + "{why}." + ), + i = "Put the files back where they were, then update again." + ), + class = "pecotmrUnreadablePanel", + parent = parent + ) +} + # PLINK2 writes the .psam header line with a leading "#" on the first field. # @noRd .psamHeaderNames <- function(nms) str_remove(nms, "^#") @@ -458,14 +570,14 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } # 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. +# file's own ids), CHR, 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))), + CHR = as.character(seqnames(gr)), BP = as.integer(start(gr)), A1 = as.character(mc$A1), A2 = as.character(mc$A2) @@ -473,12 +585,13 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { } # 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. +# named `variantIds`: a handle's, or a VCF, GDS or PLINK1 panel's rows. Every +# reader spells CHR in UCSC style as it reads the file. # @noRd .snpInfoRanges <- function(si, variantIds) { `names<-`( GenomicRanges::GRanges( - seqnames = withChrPrefix(as.character(si$CHR)), + seqnames = as.character(si$CHR), ranges = IRanges::IRanges(as.integer(si$BP), width = 1L), SNP = as.character(si$SNP), A1 = as.character(si$A1), @@ -505,12 +618,8 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { # @noRd .blockGenotypesToSe <- function(geno, handle, snpIdx) { si <- slice(snpInfo(handle), snpIdx) - chr <- str_c( - "chr", - str_remove(as.character(si$CHR), regex("^chr", ignore_case = TRUE)) - ) rowRanges <- GRanges( - seqnames = chr, + seqnames = si$CHR, ranges = IRanges(start = as.integer(si$BP), width = 1L), SNP = si$SNP, A1 = si$A1, @@ -571,7 +680,7 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { if (length(snpIdx) == 0L) { return(.emptyBlockSe(sampleIds)) } - unifiedChr <- canonChrom(snpInfo(handle)$CHR) + unifiedChr <- snpInfo(handle)$CHR groups <- split(seq_along(snpIdx), unifiedChr[snpIdx]) ses <- set_names( map2( @@ -714,16 +823,30 @@ extractBlockGenotypes <- function(handle, snpIdx, meanImpute = TRUE) { #' @title Filter SNP Info by Region #' @description Return 1-based indices into snpInfo for SNPs within a genomic -#' region string. +#' window. #' @param snpInfo data.frame with CHR and BP columns. -#' @param region Character region string "chr:start-end". +#' @param region A \code{GRanges} window, of one range or several. #' @return Integer vector of matching SNP indices. #' @keywords internal .regionToSnpIdx <- function(snpInfo, region) { - parsed <- parseRegion(region) - chrMatch <- stripChrPrefix(as.character(snpInfo$CHR)) == parsed$chrom - posMatch <- snpInfo$BP >= parsed$start & snpInfo$BP <= parsed$end - which(chrMatch & posMatch) + which(.refMultiRegionMask( + as.character(snpInfo$CHR), + snpInfo$BP, + .regionTable(region) + )) +} + +# Internal: a GRanges window argument as the chrom / start / end table the +# genotype readers match variants against, one row per range, its +# chromosome in UCSC style as the LD and genotype metadata are. +# @noRd +.regionTable <- function(region, what = "`region`") { + region <- .assertRegionGRanges(region, what) + tibble( + chrom = as.character(GenomicRanges::seqnames(region)), + start = GenomicRanges::start(region), + end = GenomicRanges::end(region) + ) } #' @title Convert SNP Info to Variant Info @@ -865,7 +988,7 @@ readBim <- function(bed) { #' Read a PLINK2 allele frequency file (.afreq or .afreq.zst) #' -#' @param prefix File prefix (without .afreq extension). +#' @param path File prefix (without .afreq extension). #' @return A data.frame with columns: chrom, id, A2 (REF), A1 (ALT), alt_freq, #' obs_ct. alt_freq is the frequency of the A1 (ALT/effect) allele. #' @importFrom vroom vroom @@ -877,24 +1000,33 @@ readBim <- function(bed) { #' readAfreq(stem) #' @export #' @importFrom checkmate assertString -readAfreq <- function(prefix) { - assertString(prefix) - afreqZst <- str_c(prefix, ".afreq.zst") - afreqPlain <- str_c(prefix, ".afreq") +readAfreq <- function(path) { + assertString(path) + afreqZst <- str_c(path, ".afreq.zst") + afreqPlain <- str_c(path, ".afreq") if (file.exists(afreqZst)) { - af <- vroom( - archive_read(afreqZst, format = "raw", filter = "zstd"), - delim = "\t", - show_col_types = FALSE - ) - } else if (file.exists(afreqPlain)) { - af <- vroom( - afreqPlain, + return(.readAfreqFile(afreqZst)) + } + if (file.exists(afreqPlain)) { + return(.readAfreqFile(afreqPlain)) + } + NULL +} + +# One PLINK2 .afreq table read from the file named, zstd-compressed when the +# name ends in .zst. readAfreq() finds that file from a prefix; a caller that +# holds the file itself (readStochasticMeta()'s format override) reads it +# here, so the file need not be named *.afreq. +# @noRd +.readAfreqFile <- function(file) { + af <- if (str_detect(file, "\\.zst$")) { + vroom( + archive_read(file, format = "raw", filter = "zstd"), delim = "\t", show_col_types = FALSE ) } else { - return(NULL) + vroom(file, delim = "\t", show_col_types = FALSE) } # PLINK2 .afreq: REF = A2, ALT = A1, ALT_FREQS = A1 (effect allele) # frequency @@ -927,8 +1059,8 @@ readAfreq <- function(prefix) { #' Reads per-variant min/max values used to invert min-max [0,2] scaling #' of stochastic genotype data. Supports two formats: #' \itemize{ -#' \item \strong{afreq}: PLINK2 .afreq/.afreq.zst with U_MIN/U_MAX columns -#' (read via \code{readAfreq}, which also returns allele frequencies). +#' \item \strong{afreq}: a PLINK2 .afreq table with U_MIN/U_MAX columns, +#' whatever the file is named (zstd-compressed when it ends in .zst). #' \item \strong{generic}: Tab-delimited file with columns id, u_min, u_max. #' } #' @@ -956,11 +1088,10 @@ readStochasticMeta <- function(path, format = NULL) { resolved <- arg_match(detected, c("afreq", "generic")) if (resolved == "afreq") { - # readAfreq expects a prefix, not a full path - strip the .afreq[.zst] - # suffix - prefix <- str_remove(path, "\\.afreq(\\.zst)?$") - af <- readAfreq(prefix) - if (is.null(af) || !all(is_in(c("u_min", "u_max"), colnames(af)))) { + # The file itself, under whatever name it has: going through + # readAfreq()'s prefix would read .afreq instead. + af <- .readAfreqFile(path) + if (!all(is_in(c("u_min", "u_max"), colnames(af)))) { return(NULL) } return(select(af, all_of(c("id", "u_min", "u_max")))) @@ -1028,7 +1159,8 @@ invertMinmaxScaling <- function(X, uMin, uMax) { abort(msg) } span <- uMax - uMin - # Monomorphic variant: the forward scaling was the identity. + # Monomorphic variant: the forward step divided by 1 rather than 0, which + # left the column all 0. denom <- replace(span, span == 0, 1) # Invert: U_original = U_scaled * (u_max - u_min) / 2 + u_min sweep(sweep(X, 2, denom / 2, "*"), 2, uMin, "+") @@ -1091,8 +1223,8 @@ readPvar <- function(pvarPath) { #' 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 -#' chrom/start/end. If NULL, returns all variants. +#' @param which Optional \code{GRanges}: return only the variants that +#' overlap it. If NULL, returns all variants. #' @return A data.frame with columns: chrom, id, pos, A2, A1. May also include #' allele_freq, variance, n_nomiss depending on source. #' @@ -1100,20 +1232,21 @@ readPvar <- function(pvarPath) { #' @examples #' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", #' package = "pecotmr") -#' refVariantInfo(meta, region = "chr22:10000000-19000000") +#' refVariantInfo(meta, +#' which = GenomicRanges::GRanges("chr22:10000000-19000000")) #' @export -refVariantInfo <- function(source, region = NULL) { +refVariantInfo <- function(source, which = NULL) { resolved <- resolveLdSource(source) - dataPath <- .refDataPath(resolved, region) + dataPath <- .refDataPath(resolved, which) if (resolved$type == "plink2") { info <- .refInfoPlink2(dataPath) } else if (resolved$type == "plink1") { info <- .refInfoPlink1(dataPath) } else { - return(.refInfoVcfGds(dataPath, region)) + return(.refInfoVcfGds(dataPath, which)) } # Region filter for plink2 / plink1 (the loader-based paths self-filter). - .refRegionFilter(info, region) + .refRegionFilter(info, which) } # Resolve the per-chromosome data path when the source carries region metadata, @@ -1140,6 +1273,7 @@ refVariantInfo <- function(source, region = NULL) { afreq <- readAfreq(dataPath) mutate( info, + chrom = withChrPrefix(.data$chrom), !!!compact(list( allele_freq = if (!is.null(afreq)) { afreq$alt_freq[match(info$id, afreq$id)] @@ -1153,7 +1287,7 @@ refVariantInfo <- function(source, region = NULL) { .refInfoPlink1 <- function(dataPath) { bim <- readBim(str_c(dataPath, ".bed")) tibble( - chrom = bim$chrom, + chrom = withChrPrefix(bim$chrom), id = bim$id, pos = bim$pos, A2 = bim$a0, @@ -1167,7 +1301,7 @@ refVariantInfo <- function(source, region = NULL) { .refInfoVcfGds <- function(dataPath, region) { result <- loadGenotypeRegion( dataPath, - region = region, + which = region, returnVariantInfo = TRUE ) mutate( @@ -1182,19 +1316,15 @@ refVariantInfo <- function(source, region = NULL) { if (is.null(region)) { return(info) } - parsed <- parseRegion(region) - infoChrom <- stripChrPrefix(info$chrom) - inRegion <- if (is.data.frame(parsed) && nrow(parsed) > 1) { - .refMultiRegionMask(infoChrom, info$pos, parsed) - } else { - infoChrom == as.character(parsed$chrom) & - info$pos >= parsed$start & - info$pos <= parsed$end - } + inRegion <- .refMultiRegionMask( + info$chrom, + info$pos, + .regionTable(region) + ) info[inRegion, , drop = FALSE] } -# OR-mask across a multi-row (one row per chrom) parsed region. +# OR-mask across a region table's rows (.regionTable()), one per range. # @noRd .refMultiRegionMask <- function(infoChrom, pos, parsed) { reduce( @@ -1239,7 +1369,7 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { ids <- read_lines(keepVariantsPath) keepVariants <- parseVariantId(ids) } - viChrom <- canonChrom(variantInfo$chrom) + viChrom <- variantInfo$chrom hasAlleles <- is_in("A1", names(keepVariants)) && is_in("A2", names(keepVariants)) && !any(is.na(keepVariants$A1)) && @@ -1279,7 +1409,8 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { #' dosages are automatically rescaled using the stored U_MIN/U_MAX values. #' #' @param genotype Path to the genotype data file, or a PLINK prefix. -#' @param region The target region in the format "chr:start-end". +#' @param which Optional \code{GRanges}: load only the variants that overlap +#' it. If NULL, loads every variant. #' @param keepIndel Whether to keep indel SNPs. #' @param keepVariantsPath Path to a file listing variants to keep. #' @param returnVariantInfo If TRUE, return a list with X (dosage matrix) and @@ -1298,11 +1429,12 @@ matchVariantsToKeep <- function(variantInfo, keepVariantsPath) { #' @examples #' stem <- sub("[.]bed$", "", #' system.file("extdata", "toy_ref.bed", package = "pecotmr")) -#' loadGenotypeRegion(genotype = stem, region = "chr22:1-100000000") +#' loadGenotypeRegion(genotype = stem, +#' which = GenomicRanges::GRanges("chr22:1-100000000")) #' @export loadGenotypeRegion <- function( genotype, - region = NULL, + which = NULL, keepIndel = TRUE, keepVariantsPath = NULL, returnVariantInfo = FALSE, @@ -1314,7 +1446,7 @@ loadGenotypeRegion <- function( format = .requireGenotypeFormat(genotype, "loadGenotypeRegion") ) variants <- .rangesSnpInfo(SummarizedExperiment::rowRanges(panel)) - snpIdx <- .loadGenoSnpIdx(variants, region) + snpIdx <- .loadGenoSnpIdx(variants, which) # Samples x variants matrix (pecotmr convention), its columns named by # the file's own variant ids; callers handle missing. extracted <- list( @@ -1345,7 +1477,10 @@ loadGenotypeRegion <- function( } snpIdx <- .regionToSnpIdx(variants, region) if (length(snpIdx) == 0) { - msg <- glue("No SNPs found in the specified region {region}") + msg <- glue( + "No SNPs found in the specified region ", + "{str_flatten(as.character(region), ', ')}" + ) abort(msg, class = "NoSnpsError") } snpIdx @@ -1530,7 +1665,7 @@ loadGenotypeRegion <- function( a2 <- map_chr(allelesSplit, `[`, 2L) tibble( SNP = snpId, - CHR = as.character(chr), + CHR = withChrPrefix(chr), BP = as.integer(pos), A1 = a1, A2 = a2 @@ -1558,6 +1693,7 @@ loadGenotypeRegion <- function( # are read here. # @noRd #' @importFrom checkmate assertFileExists +#' @importFrom purrr walk .makeBgenHandle <- function(path) { walk(c("DBI", "RSQLite"), .bgenRequirePackage) assertFileExists(path, access = "r", .var.name = "BGEN file") @@ -1738,7 +1874,7 @@ loadGenotypeRegion <- function( named <- !is.na(index$rsid) & nzchar(index$rsid) & index$rsid != "." tibble( SNP = if_else(named, index$rsid, ids), - CHR = canonChrom(index$chromosome), + CHR = withChrPrefix(index$chromosome), BP = as.integer(index$position), A1 = index$allele2, A2 = index$allele1, @@ -1755,7 +1891,7 @@ loadGenotypeRegion <- function( others <- alleles[-1L] tibble( SNP = formatVariantId(chrom, pos, alleles[[1L]], others), - CHR = canonChrom(chrom), + CHR = withChrPrefix(chrom), BP = as.integer(pos), A1 = others, A2 = alleles[[1L]], @@ -2032,7 +2168,7 @@ loadGenotypeRegion <- function( records$id[record], formatVariantId(records$chrom[record], records$pos[record], a2, a1) ), - CHR = canonChrom(records$chrom[record]), + CHR = withChrPrefix(records$chrom[record]), BP = as.integer(records$pos[record]), A1 = a1, A2 = a2, @@ -2248,7 +2384,6 @@ loadGenotypeRegion <- function( rows <- mutate( meta$snpInfo, SNP = as.character(.data$SNP), - CHR = canonChrom(.data$CHR), record = row_number(), allele = 1L ) @@ -2454,7 +2589,7 @@ loadGenotypeRegion <- function( # pecotmr convention directly. snpInfo <- tibble( SNP = bim$SNP, - CHR = as.character(bim$CHR), + CHR = withChrPrefix(bim$CHR), BP = as.integer(bim$BP), A1 = bim$A1, A2 = bim$A2 diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 9e488c0c..ff26229e 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -1,11 +1,13 @@ # ============================================================================= # GwasSumStats S4 class # ----------------------------------------------------------------------------- -# 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 ldReference + genome + qcInfo apply -# uniformly across rows. +# GRangesList-subclass collection keyed by the identity tuple (study). A study +# is split into one row per chromosome, or per window when the constructor is +# given a `region`, each holding that part of its GWAS summary statistics; +# the accessors stitch a study's rows back together. Class-level slots genome +# + qcOptions apply uniformly across rows; ldReference holds each distinct LD +# reference once, and the ldReference mcols column names the one every row +# uses. # ============================================================================= #' @include AllClasses.R tupleSelectors.R @@ -13,13 +15,30 @@ NULL #' @title GWAS Summary-Statistic Collection #' @description S4 collection of GWAS summary statistics keyed by the identity -#' tuple \code{(study)}. Each element is that study's per-variant -#' \code{GRanges} covering a single LD block, so build one collection per -#' block when sweeping the genome. -#' @details Required column: \code{study}, unique across rows. The class-level -#' slots inherited from \code{\linkS4class{SumStatsBase}} -- -#' \code{ldReference}, \code{genome} and \code{qcInfo} -- apply uniformly to -#' every row. +#' tuple \code{(study)}. A study is split into one element per chromosome, +#' or per window when \code{\link{GwasSumStats}} is given a \code{region}, +#' each a per-variant \code{GRanges}; \code{\link{sumStats}} and the other +#' accessors stitch a study's elements back together. +#' @details Required column: \code{study}; the constructor also adds +#' \code{blockId}, naming each element's chromosome or window, and the +#' element's analysis window: \code{region}, a \code{GRanges} with one +#' range per element, and \code{regionGiven}. \code{regionGiven} is +#' \code{TRUE} where the window was given as a \code{region}, and +#' \code{FALSE} where it is the span of the element's variants when the +#' collection was first built, before any QC. A QC pass carries both +#' unchanged; the span of the variants left is \code{range(x)}. +#' \code{\link{colocPipeline}}, +#' \code{\link{colocboostPipeline}} and +#' \code{\link{causalInferencePipeline}} check the QTL variants against +#' these windows. Variants past a given window lie in one that was not +#' loaded, which is an error. Variants past a computed window may only be +#' ones the GWAS lacks, so more than one in a row is a warning. +#' A study repeats across its elements, so uniqueness is on +#' \code{(study, range)}. The class-level +#' slots inherited from \code{\linkS4class{SumStatsBase}} -- \code{genome} +#' and \code{qcOptions} -- apply uniformly to every row; \code{ldReference} +#' holds each distinct LD reference once, and the \code{ldReference} column +#' names the one each row uses. #' @seealso \code{\link{GwasSumStats}} for the constructor and #' \code{\linkS4class{QtlSumStats}} for the QTL counterpart. #' @importFrom checkmate makeAssertCollection assertNames assertList @@ -38,7 +57,7 @@ setClass( add = coll ) coll$push(.sumStatsCheckGenome(object)) - assertList(object@qcInfo, .var.name = "qcInfo", add = coll) + assertList(object@qcOptions, .var.name = "qcOptions", add = coll) slotErrors <- coll$getMessages() if (length(slotErrors) > 0L) { return(slotErrors) @@ -61,23 +80,19 @@ setClass( #' @rdname show-methods setMethod("show", "GwasSumStats", function(object) { cat(glue( - "GwasSumStats: {nrow(object)} studies, ", - "genome build {GenomeInfoDb::genome(object)}\n", + "GwasSumStats: {n_distinct(object$study)} studies in ", + "{nrow(object)} rows, genome build {.showGenomeBuild(object)}\n", .trim = FALSE )) - ld <- object@ldReference - ldSrc <- if (is.null(ld)) { - "none (LD-free)" - } else { - .ldRefLabel(ld) - } + ldSrc <- .ldRefsLabel(ldReference(object), "none (LD-free)") cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) #' @title GWAS Summary Statistics Handling -#' @description Constructor, accessors, and converters for \code{GwasSumStats} -#' (the post-refactor DFrame-subclass collection keyed by \code{study}). +#' @description Constructor, accessors, and converters for +#' \code{GwasSumStats}, the \code{RangedTupleList} collection of GWAS +#' summary statistics keyed by \code{study}. #' @name pecotmr-gwas-sumstats #' @keywords internal #' @importFrom GenomicRanges GRanges seqnames start @@ -105,23 +120,26 @@ 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 reference and a single genome build that apply -#' to the whole collection. +#' @description Construct a \code{GwasSumStats} S4 collection from per-study +#' tuple vectors and a list of \code{GRanges} entries (one per study), plus +#' the LD reference(s) the rows were harmonized against and a single genome +#' build that applies to the whole collection. #' #' Each \code{GRanges} entry must carry per-variant statistics in its mcols (at #' minimum \code{SNP}, \code{A1}, \code{A2}, \code{Z}, \code{N}; optionally #' \code{MAF}, \code{INFO}, \code{BETA}, \code{SE}, \code{P}). -#' @param studyName Character vector of study identifiers (must be unique). +#' @param studyName Character vector of study identifiers, one per +#' \code{entry}. A study whose entries are already split by block repeats +#' here, once per entry, with \code{blockId} telling them apart. #' @param entry A \code{SimpleList} or \code{list} of \code{GRanges}, one per -#' study. +#' study (or per block of an already-split 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 reference. +#' \code{"hg19"}, \code{"hg38"}). One build per collection. #' @param ldReference The LD reference: a genotype panel (see #' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an -#' \code{\link{LdMatrix}}. +#' \code{\link{LdMatrix}}, used for every study, or a list with one per +#' study when they sit on different references. Each distinct reference is +#' stored once, and the \code{ldReference} column names each row's. #' @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. @@ -138,30 +156,37 @@ 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: 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 -#' this granularity: its EM estimates parameters across blocks, so a -#' per-chromosome split is too coarse. Variants overlapping no block are -#' dropped with a warning, because a variant outside every block has no -#' block-local LD to be fine-mapped against. -#' @param blockId Optional character vector of block keys, one per -#' \code{entry}, for entries that are \strong{already} split by block. Use -#' it to carry existing keys through a rebuild; without it a rebuild would -#' re-derive them as seqnames and collapse distinct blocks onto one key. -#' Mutually exclusive with \code{ldBlocks}. -#' @param extraCols Optional named list of additional per-study columns to +#' @param region Optional analysis windows, typically LD blocks: a +#' \code{GRanges}, or the path of a BED file, read as BED with a 0-based +#' start (a fourth column, when present, names each window). One set of +#' windows applies to every study; a list gives one set per study, +#' \code{NULL} for a study to split by chromosome. Each study's variants are +#' split into one element per window they fall in, rather than one per +#' chromosome, and each element's \code{region} is its window, recorded as +#' given. Its \code{blockId} is the window's name: its \code{names}, else +#' its \code{blockId} column (a BED file's fourth column), else its +#' coordinates. cTWAS needs this granularity: its EM estimates parameters +#' across blocks, so a per-chromosome split is too coarse. Variants outside +#' every window are dropped with a warning. +#' @param blockId Optional character vector of block names, one per +#' \code{entry}, for entries that are \strong{already} split. Use it to +#' carry existing names through a rebuild; without it a rebuild would +#' re-derive them as seqnames and collapse distinct blocks onto one name. A +#' name only: it gives no window, which comes from \code{region}. Mutually +#' exclusive with \code{region}. +#' @param extraCols Optional named list (or \code{DataFrame} / +#' \code{data.frame}) of additional per-study columns to #' attach to the collection's \code{mcols}. Named rather than variadic #' because the base class's own constructor, \code{GRangesList(...)}, uses #' \code{...} for its \emph{elements}: a bare \code{...} here would read #' as adding an entry rather than a metadata column. -#' @param qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} -#' on construction; populated by \code{summaryStatsQc()} with a per-step audit -#' record. Fine-mapping / TWAS pipelines reject inputs where -#' \code{length(qcInfo(x)) == 0}. +#' @param qcOptions A \code{list} recording the QC that ran. Empty +#' \code{list()} on construction; \code{summaryStatsQc()} fills it. +#' Fine-mapping / TWAS pipelines reject inputs where +#' \code{length(qcOptions(x)) == 0}. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{GwasSumStats} object. #' @examples #' panel <- readGenotypes( @@ -181,99 +206,198 @@ GwasSumStats <- function( nCase = NULL, nControl = NULL, nSample = NULL, - qcInfo = list(), - ldBlocks = NULL, + qcOptions = list(), + region = NULL, blockId = NULL, - extraCols = list() + extraCols = list(), + metadata = list() ) { if (missing(studyName) || missing(entry) || missing(genome)) { - abort("`study`, `entry`, and `genome` are all required.") + abort("`studyName`, `entry`, and `genome` are all required.") } varY <- .gwasValidateArgs(studyName, entry, genome, varY) + entry <- .ucscEntries(entry) cols <- list( study = as.character(studyName), varY = varY ) |> .gwasAppendOptional(nCase, nControl, nSample, studyName) |> .gwasAppendExtras(extraCols) - dfArgs <- c(cols, list(check.names = FALSE)) - # The per-study GRanges become the collection's ELEMENTS; everything else - # is per-study metadata and goes in mcols. There is no `entry` column. - # mcols are attached to the GRangesList BEFORE new(), because new() - # validates during initialize() and the validity method needs the identity - # columns to already be there. - # A multi-seqname entry (e.g. a genome-wide GWAS) is split into one - # element per block (or per chromosome when no block manifest is given), - # with its metadata row replicated alongside. Splitting is unconditional: - # a stored element always spans exactly one seqname. - split <- .gwasSplitEntry(entry, ldBlocks, blockId, length(entry)) - # `blockId` is always present, so downstream code (cTWAS in particular) can - # key regions without first asking how the collection was built. - md <- cbind( - exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], - S4Vectors::DataFrame(blockId = split$blockId) + dict <- .ldRefDict(.ldRefPerTuple(ldReference, length(entry))) + dfArgs <- c(cols, list(ldReference = dict$keys, check.names = FALSE)) + grl <- .gwasElements(entry, dfArgs, region, blockId) + .withMetadata( + .sumStatsNewValidated( + "GwasSumStats", + grl, + dict$refs, + genome, + qcOptions + ), + metadata + ) +} + +# The collection's elements with their metadata. The per-study GRanges become +# the ELEMENTS; everything else is per-study metadata and goes in mcols. There +# is no `entry` column. mcols are attached to the GRangesList BEFORE new(), +# because new() validates during initialize() and the validity method needs +# the identity columns to already be there. +# A multi-seqname entry (e.g. a genome-wide GWAS) is split into one element +# per `region` window (or per chromosome when there are none), with its +# metadata row replicated alongside. Splitting is unconditional: a stored +# element always spans exactly one seqname. +# @noRd +.gwasElements <- function(entry, dfArgs, region, blockId) { + split <- .gwasSplitEntry(entry, region, blockId, length(entry)) + pieces <- .rtlBindElements(split$entry) + S4Vectors::`mcols<-`( + pieces, + value = .gwasPieceMetadata(dfArgs, split, pieces) ) - grl <- S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(split$entry), - value = md +} + +# Each piece's metadata row: its entry's, replicated across the pieces the +# entry splits into, then the block the piece covers. `blockId` is always +# present, so downstream code (cTWAS in particular) can key regions without +# first asking how the collection was built. So are `region` and +# `regionGiven`, so the block range of a row, and whether the caller gave it, +# need no fallback either. +# @noRd +.gwasPieceMetadata <- function(dfArgs, split, pieces) { + cbind( + exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], + exec( + S4Vectors::DataFrame, + blockId = split$blockId, + !!!.regionColumns( + split$given, + split$hasGiven, + .rowSpanRanges(pieces) + ) + ) ) - .sumStatsNewValidated("GwasSumStats", grl, ldReference, genome, qcInfo) } # Build and validate a SumStatsBase subclass from its GRangesList plus the # three collection-level slots GwasSumStats and QtlSumStats share. Shared # rather than duplicated so the two constructors cannot drift in how they -# coerce those slots. Used by qtlSumStats.R too. +# coerce those slots. Used by qtlSumStats.R too. `ldReference` is the named +# list of distinct references (.ldRefDict()), already keyed from the rows. # @noRd -.sumStatsNewValidated <- function(Class, grl, ldReference, genome, qcInfo) { +.sumStatsNewValidated <- function(Class, grl, ldReference, genome, qcOptions) { # 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. - built <- GenomeInfoDb::`genome<-`(grl, value = as.character(genome)) - obj <- methods::new( + built <- .rtlNamed( + GenomeInfoDb::`genome<-`(grl, value = as.character(genome)) + ) + methods::new( Class, built, - ldReference = .asLdRef(ldReference), - qcInfo = as.list(qcInfo) + ldReference = ldReference, + qcOptions = as.list(qcOptions) ) - methods::validObject(obj) - obj } -# Split by LD block when a manifest is supplied, else by seqname. Both return -# (entry, fromIdx); this adds the blockId the seqname path does not carry, -# which for that path is just the seqname each piece sits on. +# Split across the `region` windows when they are given, else by seqname. +# Both return (entry, fromIdx); this adds each piece's blockId -- its window's +# name, or on the seqname path the seqname it sits on -- and its given window +# (`given`, with `hasGiven` saying which pieces have one). # @noRd -.gwasSplitEntry <- function(entry, ldBlocks, blockId, n) { - if (!is.null(ldBlocks) && !is.null(blockId)) { +.gwasSplitEntry <- function(entry, region, blockId, n) { + if (!is.null(region) && !is.null(blockId)) { msg <- glue( - "pass `ldBlocks` (derive the keys) or `blockId` (supply them), ", - "not both." + "pass `region` (its windows name the rows) or `blockId` (supply ", + "the names), not both." ) abort(msg) } - if (!is.null(ldBlocks)) { - return(.rtlSplitByBlocks(entry, .asLdBlockRanges(ldBlocks))) + if (!is.null(region)) { + return(.gwasSplitByRegion(entry, region, n)) } split <- .rtlSplitBySeqname(entry) # Supplied ids are indexed by fromIdx, exactly like the other metadata # columns, so an entry that still splits further replicates its id rather # than falling out of alignment. This is what lets a rebuild (QC) carry # block keys through instead of silently re-deriving them as seqnames. + # unname(): the seqname splitter names its pieces, and those names would + # otherwise ride into the mcols column and make it inconsistent with the + # window path, which produces a bare character vector. + ids <- if (is.null(blockId)) { + unname(map_chr(split$entry, .rtlElementSeqname)) + } else { + .gwasCheckBlockId(blockId, n)[split$fromIdx] + } list_assign( split, - blockId = if (!is.null(blockId)) { - .gwasCheckBlockId(blockId, n)[split$fromIdx] - } else { - # unname(): the seqname splitter names its pieces, and those names - # would otherwise ride into the mcols column and make it - # inconsistent with the block path, which produces a bare - # character vector. - unname(map_chr(split$entry, .gwasElementSeqname)) - } + blockId = ids, + given = .placeholderRanges(length(split$entry)), + hasGiven = rep(FALSE, length(split$entry)) + ) +} + +# Each study split across its windows: one set shared by every study, or a +# list with one per study (NULL for a study to split by chromosome), as +# `ldReference` takes one reference or a list. +# @noRd +.gwasSplitByRegion <- function(entry, region, n) { + if (!.isPerStudyRegion(region)) { + return(.gwasWindowSplit(entry, .asRegionRanges(region))) + } + if (length(region) != n) { + abort(glue( + "`region` as a list must have one element per `entry` ", + "(got {length(region)} vs {n})." + )) + } + .gwasCombineSplits(map2(as.list(entry), as.list(region), .gwasSplitStudy)) +} + +# @noRd +.isPerStudyRegion <- function(region) { + methods::is(region, "GRangesList") || + (is.list(region) && !is.data.frame(region)) +} + +# @noRd +.gwasWindowSplit <- function(entry, windows) { + split <- .rtlSplitByBlocks(entry, windows) + list_assign( + split, + given = .bareRanges(split$blockRange), + hasGiven = rep(TRUE, length(split$entry)), + blockRange = zap() ) } +# One study against its own windows, or by chromosome when it has none. +# @noRd +.gwasSplitStudy <- function(e, r) { + if (is.null(r)) { + return(.gwasSplitEntry(list(e), NULL, NULL, 1L)) + } + .gwasWindowSplit(list(e), .asRegionRanges(r)) +} + +# Per-study splits as one: each study's pieces in turn, with `fromIdx` +# pointing back at the study they came from. +# @noRd +.gwasCombineSplits <- function(splits) { + list( + entry = list_flatten(map(splits, "entry")), + fromIdx = rep(seq_along(splits), map_int(splits, .gwasSplitSize)), + blockId = list_c(map(splits, "blockId"), ptype = character()), + given = unname(unlist(.rtlBindElements(map(splits, "given")))), + hasGiven = list_c(map(splits, "hasGiven"), ptype = logical()) + ) +} + +# @noRd +.gwasSplitSize <- function(split) { + length(split$entry) +} + # @noRd .gwasCheckBlockId <- function(blockId, n) { if (length(blockId) != n) { @@ -286,23 +410,13 @@ GwasSumStats <- function( as.character(blockId) } -# The one seqname an already-split element sits on. NA for an empty element, -# which carries no coordinate to name. -# @noRd -.gwasElementSeqname <- function(g) { - if (length(g) == 0L) { - return(NA_character_) - } - as.character(seqnames(g))[[1L]] -} - # Validate genome / entry / length consistency; returns the recycled varY. # @noRd .gwasValidateArgs <- function(studyName, entry, genome, varY) { if (length(genome) != 1L) { msg <- glue( "`genome` must be a single character string (one build per ", - "collection, because all entries share the LD reference)." + "collection)." ) abort(msg) } @@ -344,7 +458,7 @@ GwasSumStats <- function( # Append any user-supplied extra columns (from `...`). # @noRd .gwasAppendExtras <- function(cols, extras) { - c(cols, extras) + c(cols, .extraColsList(extras)) } @@ -369,7 +483,7 @@ GwasSumStats <- function( } msg <- glue( "This GwasSumStats has {n_distinct(studies)} studies. ", - "Pass `study = ` to select one. ", + "Pass `studyName = ` to select one. ", "Available: {str_flatten(unique(studies), ', ')}" ) abort(msg) @@ -391,8 +505,6 @@ GwasSumStats <- function( #' @param x A \code{GwasSumStats} object. #' @param studyName Character (length 1) study identifier. Optional when the #' collection has a single row. -#' @param ranges Optional \code{GRanges} restricting the returned variants to -#' those it overlaps. \code{NULL} (default) returns the study's full set. #' @param context,trait,annotateSignificance QTL-only selectors, named here so #' that supplying one is an error rather than a silently ignored request. A #' GWAS has no context or trait axis and carries no significance annotation; @@ -405,7 +517,6 @@ setMethod( function( x, studyName = NULL, - ranges = NULL, context = NULL, trait = NULL, annotateSignificance = NULL @@ -416,7 +527,7 @@ setMethod( # silently ignored request -- the shared SumStatsBase accessors pass # the union of both classes' selectors. .gwasRefuseQtlSelectors(context, trait, annotateSignificance) - .ssStitchElements(x, .gwasSelectStudy(x, studyName), ranges) + .ssStitchElements(x, .gwasSelectStudy(x, studyName)) } ) @@ -433,77 +544,27 @@ setMethod( abort(glue( "sumStats(GwasSumStats): {str_flatten(names(given)[given], ', ')} ", "{if (sum(given) == 1L) 'is' else 'are'} a QtlSumStats selector. ", - "A GWAS is selected by `study` (and narrowed by `ranges`)." + "A GWAS is selected by `studyName`; narrow it first with ", + "subsetByOverlaps()." )) } # z / nSamples / maf / nSnps are provided once by SumStatsBase (AllClasses.R). -#' @title Coerce Summary Statistics to a Data Frame -#' @description Coerce one tuple of a \code{GwasSumStats} or -#' \code{QtlSumStats} collection to a per-variant \code{data.frame} in the -#' standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, -#' maf} (optional columns omitted when absent on the entry). This is the -#' table view of \code{\link{sumStats}}, which returns the same selection as -#' a \code{GRanges}; coercion rather than a return-type argument is the -#' Bioconductor idiom for choosing a representation. -#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. -#' @param row.names,optional Accepted for compatibility with -#' \code{as.data.frame} and ignored. -#' @param studyName Character (length 1) or \code{NULL}. Restrict the selection -#' to this study; \code{NULL} matches all studies. -#' @param context Character (length 1) or \code{NULL}. Restrict the selection to -#' this context; \code{NULL} matches all contexts (\code{QtlSumStats} only). -#' @param trait Character (length 1) or \code{NULL}. Restrict the selection to -#' this trait; \code{NULL} matches all traits (\code{QtlSumStats} only). -#' @param require Character vector. Columns that must be present (derived if -#' necessary) in the returned summary-statistics data frame. -#' @param derive Whether to derive missing standard columns from the available -#' ones; \code{"zFromBetaSe"} recovers \code{z} from \code{beta}/\code{se}. -#' @param keepChrPrefix Logical. If \code{TRUE}, keep the \code{chr} prefix on -#' chromosome names; otherwise strip it. -#' @param ... Unused. -#' @return A \code{data.frame}. -#' @examples -#' data(qtlSumStatsExample) -#' head(as.data.frame(qtlSumStatsExample)) -#' @rdname sumStatsDataFrame -#' @aliases sumStatsDataFrame -#' @export -setMethod( - "as.data.frame", - "GwasSumStats", - function( - x, - row.names = NULL, - optional = FALSE, - studyName = NULL, - require = character(0), - derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE, - ... - ) { - derive <- arg_match(derive) - gr <- sumStats(x, studyName = studyName) - .entryToSumstatDf( - gr, - require = require, - derive = derive, - keepChrPrefix = keepChrPrefix, - label = glue( - "GwasSumStats[", - "{if (is.null(studyName)) '' else studyName}]" - ) - ) - } -) - - #' @rdname varY #' @export setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { idx <- .gwasSelectStudy(x, studyName) - val <- x$varY[[idx]] + # One value per study, held on each of its rows; rows that disagree have + # no single answer, so that is an error rather than a pick. + val <- unique(as.numeric(x$varY[idx])) + if (length(val) > 1L) { + abort(glue( + "varY(): the {length(idx)} rows of study ", + "'{x$study[[idx[[1L]]]]}' disagree on varY ", + "({str_flatten(val, ', ')})." + )) + } if (is.na(val)) NULL else val }) @@ -522,22 +583,23 @@ setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { #' #' The three collection-level slots are merged rather than taken from the first #' 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 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}. +#' across the inputs (a mismatch is an error, not a silent first-wins), each +#' row keeps its own QC audit, so \code{\link{qcDiagnostics}} keeps +#' addressing the right element, and every row keeps its own LD reference. +#' References that are views of one source are stored once: genotype panels +#' read from the same files union into one panel over the shared genotype +#' handle (block-parallel pipelines narrow each +#' piece's panel to its own block, so a multi-block collection would otherwise +#' hold one panel per block), and an \code{LdMatrix} or +#' \code{GenotypeMixture} that another input's reference covers gives way to +#' that one. Inputs on unrelated references keep both. #' #' @param ... Two or more \code{GwasSumStats} objects, or a single \code{list} #' of them. -#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) -#' to attach to the combined collection, overriding the unioned one. Default -#' \code{NULL}. +#' @param ldReference Optional LD reference -- a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +#' \code{LdMatrix} -- that every row of the combined collection uses +#' instead of its own. Default \code{NULL}. #' @return A single combined \code{GwasSumStats}. #' @seealso \code{\link{combineQtlSumStats}}, #' \code{\link{combineFineMappingResults}}, \code{\link{combineTwasWeights}} diff --git a/R/h2Annotations.R b/R/h2Annotations.R index 1a23f69b..b42afed4 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -19,19 +19,19 @@ NULL #' @export setMethod( "readAnnotations", - signature(paths = "character"), - function(paths, snpRanges, annotationMeta = NULL, genome = "hg19") { - if (is.null(names(paths))) { + signature(path = "character"), + function(path, snpRanges, annotationMeta = NULL, genome = "hg19") { + if (is.null(names(path))) { msg <- glue( - "'paths' must be a named character vector (names = ", + "'path' must be a named character vector (names = ", "annotation names)" ) abort(msg) } - annotNames <- names(paths) - nAnnots <- length(paths) + annotNames <- names(path) + nAnnots <- length(path) annotMat <- .readAnnotMatrix( - paths, + path, snpRanges, annotNames, length(snpRanges), @@ -41,7 +41,7 @@ setMethod( annotationMeta <- tibble( name = annotNames, tier = rep("candidate", nAnnots), - type = .readAnnotTypes(paths) + type = .readAnnotTypes(path) ) } AnnotationMatrix(annotMat, snpRanges, annotationMeta, genome) diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index a35a813b..7643d9cf 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -34,7 +34,8 @@ NULL #' @description For each LD block, find the SNP indices from a reference that #' fall within the block boundaries. #' @param snpInfo A data.frame with columns CHR, BP. -#' @param ldBlocks A \code{GRanges} of LD block intervals. +#' @param ldBlocks The LD block intervals: a \code{GRanges}, or the path +#' of a BED file, read as BED with a 0-based start. #' @return A list of integer vectors, one per block. #' @keywords internal snpsPerBlock <- function(snpInfo, ldBlocks) { @@ -967,10 +968,10 @@ NULL 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 + ldFactor <- ld$F + m1 <- nrow(ldFactor) - 1 + gram <- tcrossprod(sweep(ldFactor, 2L, sqrt(d), "*")) + crossprod(ldFactor, rawNtau / m1 * (gram %*% ldFactor) + ldFactor) / m1 } # One block's contribution to the GLS normal equations, L = X'Omega^-1 X and @@ -2137,14 +2138,17 @@ sldscUnivariate <- function( if (!is.null(studyName)) { return(studyName) } - if (nrow(sumstats) != 1L) { + # Studies, not rows: a genome-wide study is one row per chromosome (or + # per LD block), and its accessors stitch those rows back together. + studies <- unique(as.character(sumstats$study)) + if (length(studies) != 1L) { msg <- glue( - "`study` is required when the GwasSumStats has ", - "{nrow(sumstats)} entries." + "`studyName` is required when the GwasSumStats has ", + "{length(studies)} studies." ) abort(msg) } - as.character(sumstats$study[[1L]]) + studies } # Dispatch to the method-specific univariate estimator. @@ -2235,11 +2239,10 @@ sldscUnivariate <- function( # Element-wise coordinate check. Coordinates are compared rather than variant # ids because the two sides routinely name the same variant differently # (rsid vs chr:pos:A2:A1), while the same variant always sits at the same -# coordinate once the chr prefix is normalized. +# coordinate. # @noRd .h2CheckPositions <- function(entry, ldRef, studyName) { - same <- withChrPrefix(as.character(seqnames(entry))) == - withChrPrefix(as.character(seqnames(ldRef))) & + same <- as.character(seqnames(entry)) == as.character(seqnames(ldRef)) & start(entry) == start(ldRef) if (all(same)) { return(invisible(TRUE)) @@ -2292,7 +2295,7 @@ setMethod( studyName <- .estimateH2ResolveStudy(sumstats, studyName) .h2ValidateInputs(sumstats, studyName, ldRef, annotations) z <- z(sumstats, studyName = studyName) - rawN <- median(nSamples(sumstats, studyName = studyName)) + rawN <- median(sampleSize(sumstats, studyName = studyName)) M <- nSnps(sumstats, studyName = studyName) # Legacy heritability-wrapper correction (separate from the SuSiE RSS # binaryTraitModel handling in the fine-mapping pipeline). diff --git a/R/jointEngine.R b/R/jointEngine.R index 77a9f6a5..5f1ff8f9 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -108,15 +108,19 @@ NULL # column (NULL when absent -- the true position cannot be inferred # from summary statistics alone). # region = the fine-mapping window. QtlDataset -> traitPos +/- cisWindow; -# QtlSumStats -> the entry's variant span (sumstats carry no -# cis-window, so the fitted span IS the region). +# QtlSumStats -> the tuple's own `region`: the window it was +# given, or the span of its variants as first built, before QC +# (a pipeline's cisWindow sets it from traitPos first). # Each returns a length-1 GRanges, or NULL when the anchor is unavailable (the -# accumulator / builder then records a chrUn sentinel). +# accumulator / builder then records a chrUn sentinel). A row is named by its +# whole (study, context, trait) tuple: a QtlSumStats can carry the same +# (context, trait) in several studies, each with its own position and window. +# A QtlDataset holds one study, so `study` has nothing to choose there. #' @importFrom rlang try_fetch -.traitPosFor <- function(data, context, trait) { +.traitPosFor <- function(data, study, context, trait) { if (methods::is(data, "QtlDataset")) { se <- try_fetch( - molecularTraits(data, contexts = context), + .qtlContextSe(data, context = context), error = function(cnd) NULL ) if (is.null(se)) { @@ -137,10 +141,7 @@ NULL if (!is_in("traitPos", colnames(data))) { return(NULL) } - idx <- which( - as.character(data$context) == context & - as.character(data$trait) == trait - ) + idx <- .qssTupleRows(data, study, context, trait) if (length(idx) == 0L) { return(NULL) } @@ -152,9 +153,9 @@ NULL NULL } -.fitRegionFor <- function(data, context, trait, cisWindow = NULL) { +.fitRegionFor <- function(data, study, context, trait, cisWindow = NULL) { if (methods::is(data, "QtlDataset")) { - tp <- .traitPosFor(data, context, trait) + tp <- .traitPosFor(data, study, context, trait) if (is.null(tp)) { return(NULL) } @@ -168,34 +169,32 @@ NULL )) } if (methods::is(data, "QtlSumStats")) { - idx <- which( - as.character(data$context) == context & - as.character(data$trait) == trait - ) + idx <- .qssTupleRows(data, study, context, trait) if (length(idx) == 0L) { return(NULL) } - gr <- .collectionEntry(data, idx[[1L]]) - if (length(gr) == 0L) { - return(NULL) - } - return(GenomicRanges::GRanges( - as.character(GenomicRanges::seqnames(gr))[[1L]], - IRanges::IRanges( - min(GenomicRanges::start(gr)), - max(GenomicRanges::end(gr)) - ) - )) + return(.rowRegionAt(data, idx[[1L]])) } NULL } +# The rows of a QtlSumStats holding one (study, context, trait) tuple. +# @noRd +.qssTupleRows <- function(data, study, context, trait) { + which( + as.character(data$study) == study & + as.character(data$context) == context & + as.character(data$trait) == trait + ) +} + # Vectorised per-row anchors for the pushRow builders: map the scalar helper -# over aligned (context, trait) vectors and assemble ONE GRanges of length n, -# using a chrUn sentinel where the anchor is unavailable. Built from plain -# chr/start/end vectors so mixed seqlevels never trip seqinfo merging. +# over aligned (study, context, trait) vectors and assemble ONE GRanges of +# length n, using a chrUn sentinel where the anchor is unavailable. Built from +# plain chr/start/end vectors so mixed seqlevels never trip seqinfo merging. .anchorVector <- function( data, + studies, contexts, traits, kind = c("traitPos", "region"), @@ -206,6 +205,7 @@ NULL seq_along(traits), .jointAnchorAt, data = data, + studies = studies, contexts = contexts, traits = traits, kind = kind, @@ -216,10 +216,8 @@ NULL starts <- map_int(anchors, "start") ends <- map_int(anchors, "end") # Nothing resolved (e.g. a QtlSumStats with no supplied traitPos): return - # NULL - # so the builder omits the column entirely and traitPosition() reports - # NA, - # rather than a column full of chrUn sentinels. + # NULL so the builder omits the column entirely and traitPosition() + # reports an empty GRanges, rather than a column full of chrUn sentinels. if (!anyFound) { return(NULL) } @@ -233,11 +231,25 @@ NULL # records which it was, so the caller can tell "nothing resolved" from "every # anchor really is chrUn:1-1". # @noRd -.jointAnchorAt <- function(i, data, contexts, traits, kind, cisWindow) { +.jointAnchorAt <- function( + i, + data, + studies, + contexts, + traits, + kind, + cisWindow +) { g <- if (kind == "traitPos") { - .traitPosFor(data, contexts[[i]], traits[[i]]) + .traitPosFor(data, studies[[i]], contexts[[i]], traits[[i]]) } else { - .fitRegionFor(data, contexts[[i]], traits[[i]], cisWindow) + .fitRegionFor( + data, + studies[[i]], + contexts[[i]], + traits[[i]], + cisWindow + ) } if (is.null(g)) { return(list(found = FALSE, chr = "chrUn", start = 1L, end = 1L)) @@ -264,6 +276,7 @@ NULL per <- try_fetch( .anchorVector( data, + as.character(cond$study), as.character(cond$context), as.character(cond$trait), "region", @@ -286,7 +299,7 @@ NULL # taken from the fit's OWN variants rather than a trait cis-window: a joint # group spans several traits, so no single trait's window describes X. # @noRd -.jointAfForGroup <- function(data, g) { +.jointAfForGroup <- function(data, g, genotypeFilter) { if (!is(g, "IndividualJointGroup")) { return(NULL) } @@ -298,7 +311,7 @@ NULL if (is.null(rg)) { return(NULL) } - .fmAfForX(data, X, region = rg) + .fmAfForX(data, X, genotypeFilter = genotypeFilter, region = rg) } @@ -426,7 +439,7 @@ setMethod( coverage = cfg$credibleSetParam$coverage, pos = .jgTraitPos(group), verbose = verbose, - numThreads = cv$numThreads %||% 1L, + BPPARAM = cv$BPPARAM %||% SerialParam(), seed = cfg$seed ) .fmSliceCv(cv, "fsusie") @@ -624,7 +637,7 @@ setMethod( verbose = verbose, mvPrior = mvPrior, mvPriorCv = mvPriorCv, - numThreads = cv$numThreads %||% 1L, + BPPARAM = cv$BPPARAM %||% SerialParam(), seed = cfg$seed ) .fmSliceCv(cv, "mvsusie") @@ -1153,7 +1166,7 @@ setMethod( weightMethods = wm, fitRetention = "slim", maxNumVariants = maxCv, - numThreads = cfg$crossValidationParam$numThreads %||% 1, + BPPARAM = cv$BPPARAM %||% SerialParam(), dataDrivenPriorMatricesCv = args$dataDrivenPriorMatricesCv, verbose = cfg$verbose %||% 1, seed = cfg$seed @@ -1192,7 +1205,7 @@ setMethod( NULL } if (is.null(full$W)) { - return(twasWeightsRow( + return(TwasWeightsRow( variantIds = character(0), weights = NULL, cvResult = cvR, @@ -1200,7 +1213,7 @@ setMethod( weightsDataType = cfg$dataType )) } - twasWeightsRow( + TwasWeightsRow( variantIds = full$vids, weights = full$W[, r], methodFits = full$fitParts, @@ -1257,24 +1270,20 @@ setMethod( # 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) { +.buildJointResult <- function(constructor, records) { if (length(records) == 0L) { return(NULL) } parts <- map(records, .jointBuildRecordPart, constructor = constructor) - .rbindCollections(parts, ldReference = ldReference) + .rbindCollections(parts) } setMethod("construct", "FmJointPipeline", function(pipeline, records) { - .buildJointResult( - QtlFineMappingResult, - records, - .jpConfig(pipeline)$ldReference - ) + .buildJointResult(QtlFineMappingResult, records) }) setMethod("construct", "TwasJointPipeline", function(pipeline, records) { - .buildJointResult(TwasWeights, records, .jpConfig(pipeline)$ldReference) + .buildJointResult(TwasWeights, records) }) # ---- enumerators (pattern x dataForm -> list) -------------------- @@ -1296,7 +1305,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scopedTraits, .enumCrossContextGroupFor, data = data, - study = studyName, + studyName = studyName, scopedContexts = scopedContexts, args = args, verbose = verbose @@ -1321,7 +1330,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { verbose, label = "jointCrossContext", region = args$region, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter, + phenotypeFilter = args$phenotypeFilter ) if (is.null(xy)) { return(NULL) @@ -1340,7 +1351,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-context / sumstats. .enumCrossContextSumstats <- function(data, scope, args = list()) { - ldReference <- ldReference(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1350,7 +1360,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data = data, scope = scope, args = args, - ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1366,6 +1375,35 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { list_c(pieces) } +# The one LD reference a summary-statistics joint group's rows share. A joint +# fit reads a single LD matrix for all its conditions, so rows on different +# references cannot be fit together; that is refused, naming them, rather +# than fitting some rows against LD they were never harmonized to. +# @noRd +.jointRowsLdRef <- function(data, rows, label) { + keys <- .ldRefKeys(data)[rows] + if (n_distinct(keys) > 1L) { + tuples <- str_c( + data$study[rows], + data$context[rows], + data$trait[rows], + sep = ":" + ) + abort(c( + glue( + "{label}: a joint fit uses one LD matrix, but its rows use ", + "different LD references." + ), + i = str_c( + "Rows and their references: ", + str_flatten(str_c(tuples, " -> ", keys), "; ") + ), + i = "Fit them separately, or give them one LD reference." + )) + } + .rowLdRef(data, rows[[1L]]) +} + # One study's cross-context groups (none when it has fewer than two contexts). # @noRd .enumCrossContextSumstatsForStudy <- function( @@ -1373,7 +1411,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data, scope, args, - ldReference, studyCol, contextCol, traitCol @@ -1389,7 +1426,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s = s, scopedContexts = scopedContexts, args = args, - ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1405,7 +1441,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s, scopedContexts, args, - ldReference, studyCol, contextCol, traitCol @@ -1416,12 +1451,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(tupleRows) < 2L) { return(NULL) } + label <- "jointCrossContext (QtlSumStats)" + ldReference <- .jointRowsLdRef(data, tupleRows, label) ctxNames <- contextCol[tupleRows] jz <- .buildJointSumstatZMatrix( data, tupleRows, ctxNames, - errorLabel = "jointCrossContext (QtlSumStats)", + errorLabel = label, ldReference = ldReference, cutoffs = args$cutoffs ) @@ -1448,7 +1485,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scopedContexts, .enumCrossTraitGroupFor, data = data, - study = studyName, + studyName = studyName, scopedTraits = scopedTraits, args = args, verbose = verbose @@ -1474,7 +1511,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { label = "jointCrossTrait", studyName = studyName, region = args$region, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter, + phenotypeFilter = args$phenotypeFilter ) if (is.null(xy)) { return(NULL) @@ -1501,7 +1540,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # cross-trait / sumstats. .enumCrossTraitSumstats <- function(data, scope, args = list()) { - ldReference <- ldReference(data) studyCol <- as.character(data$study) contextCol <- as.character(data$context) traitCol <- as.character(data$trait) @@ -1511,7 +1549,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data = data, scope = scope, args = args, - ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1524,7 +1561,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data, scope, args, - ldReference, studyCol, contextCol, traitCol @@ -1536,7 +1572,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s = s, scopedTraits = scope$traits[[s]], args = args, - ldReference = ldReference, studyCol = studyCol, contextCol = contextCol, traitCol = traitCol @@ -1552,7 +1587,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { s, scopedTraits, args, - ldReference, studyCol, contextCol, traitCol @@ -1563,12 +1597,14 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(tupleRows) < 2L) { return(NULL) } + label <- "jointCrossTrait (QtlSumStats)" + ldReference <- .jointRowsLdRef(data, tupleRows, label) trNames <- traitCol[tupleRows] jz <- .buildJointSumstatZMatrix( data, tupleRows, trNames, - errorLabel = "jointCrossTrait (QtlSumStats)", + errorLabel = label, ldReference = ldReference, cutoffs = args$cutoffs ) @@ -1585,7 +1621,6 @@ 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()) { - ldReference <- ldReference(data) cols <- list( study = as.character(data$study), context = as.character(data$context), @@ -1600,8 +1635,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scope = scope, args = args, cols = cols, - allTrs = allTrs, - ldReference = ldReference + allTrs = allTrs )) } @@ -1613,8 +1647,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scope, args, cols, - allTrs, - ldReference + allTrs ) { compact(map( allTrs, @@ -1623,38 +1656,21 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scope = scope, args = args, cols = cols, - cx = cx, - ldReference = ldReference + cx = cx )) } # `map()` hands the trait first; .enumCrossStudyGroup takes it sixth. # @noRd -.enumCrossStudyGroupFor <- function( - tid, - data, - scope, - args, - cols, - cx, - ldReference -) { - .enumCrossStudyGroup(data, scope, args, cols, cx, tid, ldReference) +.enumCrossStudyGroupFor <- function(tid, data, scope, args, cols, cx) { + .enumCrossStudyGroup(data, scope, args, cols, cx, tid) } # 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, - ldReference -) { +.enumCrossStudyGroup <- function(data, scope, args, cols, cx, tid) { candidates <- which( cols$context == cx & cols$trait == tid & @@ -1672,6 +1688,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(tupleRows) < 2L) { return(NULL) } + ldReference <- .jointRowsLdRef(data, tupleRows, "jointCrossStudy") stNames <- cols$study[tupleRows] jz <- .buildJointSumstatZMatrix( data, @@ -1712,7 +1729,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { verbose, label = "composed", region = args$region, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter, + phenotypeFilter = args$phenotypeFilter ) if (is.null(xy)) { return(list()) @@ -1729,6 +1748,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { list(new("IndividualJointGroup", conditions = conds, X = xy$X, Y = xy$Y)) } +# The run's resolved phenotype QC, or the univariate fits' own default -- drop +# a sample with a missing value, keep outliers -- when the engine record +# carries none. +# @noRd +.jointPhenotypeFilter <- function(args) { + args$phenotypeFilter %||% + .qtlResolvePhenotypeFilter( + PhenotypeFilterParam(), + naDefault = "drop", + naAllowed = c("drop", "impute"), + caller = "the joint engine" + ) +} + # univariate / individual: one 1-condition group per (study, context, trait) in # scope -- the per-(context, trait) iteration expressed as engine groups, so # univariate methods (lasso / enet / susie / ...) flow through the SAME per- @@ -1738,15 +1771,15 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (!is_in(studyName, scope$studies)) { return(list()) } - naAction <- if (is.null(args$naAction)) "drop" else args$naAction + phenotypeFilter <- .jointPhenotypeFilter(args) .jeConcat(map( scope$contexts[[studyName]], .enumUnivariateForContext, data = data, scope = scope, args = args, - study = studyName, - naAction = naAction + studyName = studyName, + phenotypeFilter = phenotypeFilter )) } @@ -1758,9 +1791,9 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { scope, args, studyName, - naAction + phenotypeFilter ) { - se <- molecularTraits(data, contexts = cx) + se <- .qtlContextSe(data, context = cx) traits <- keep( intersect(scope$traits[[studyName]], rownames(se)), .traitSelectedAt, @@ -1773,21 +1806,28 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumUnivariateGroupFor, data = data, args = args, - study = studyName, + studyName = studyName, cx = cx, - naAction = naAction + phenotypeFilter = phenotypeFilter )) } # One (context, trait) univariate group, or NULL when fewer than two samples # are shared between its genotypes and its phenotype. # @noRd -.enumUnivariateGroupFor <- function(tid, data, args, studyName, cx, naAction) { +.enumUnivariateGroupFor <- function( + tid, + data, + args, + studyName, + cx, + phenotypeFilter +) { Y <- .fmResidPheno( data, contexts = cx, traitId = tid, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = args$residualizationParam ) X <- if (is.null(args$region)) { @@ -1796,14 +1836,16 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = tid, cisWindow = args$cisWindow, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter ) } else { .fmResidGeno( data, contexts = cx, region = args$region, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter ) } common <- intersect(rownames(X), rownames(Y)) @@ -1823,7 +1865,6 @@ 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") - ldReference <- ldReference(data) gi <- .enumerateComposedSumstatGroups(list(axes = axes), data, scope) if (is.null(gi)) { return(list()) @@ -1836,23 +1877,24 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumComposedGroupFor, data = data, gi = gi, - args = args, - ldReference = ldReference + args = args ))) } # 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, ldReference) { +.enumComposedGroupFor <- function(gIdx, data, gi, args) { if (length(gIdx) < 2L) { return(NULL) } + label <- "composed (QtlSumStats)" + ldReference <- .jointRowsLdRef(data, gIdx, label) jz <- .buildJointSumstatZMatrix( data, gIdx, map_chr(gIdx, .jointGroupColLabel, gi = gi), - errorLabel = "composed (QtlSumStats)", + errorLabel = label, ldReference = ldReference, cutoffs = args$cutoffs ) @@ -2093,10 +2135,11 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { js = .jointAxisMembers(cond, "study"), jc = .jointAxisMembers(cond, "context"), jt = .jointAxisMembers(cond, "trait"), - region = .jointGroupWindow(data, cond, args) + region = .jointGroupWindow(data, cond, args), + ldReference = .jgLdRefOf(g) ) fitArgs <- .twasGroupArgs(g, pipeline, args) - fitArgs$af <- .jointAfForGroup(data, g) + fitArgs$af <- .jointAfForGroup(data, g, args$genotypeFilter) fitArgs$region <- args$region perTokenEntries <- compact(set_names( map( @@ -2327,7 +2370,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ew <- ens$ensembleTwasWeights vids <- (if (!is.null(names(ew))) names(ew) else rownames(ew)) %||% variantIds(perTokenEntries[[passing[1L]]][[r]]) - twasWeightsRow( + TwasWeightsRow( variantIds = vids, weights = as.numeric(ew), cvResult = list( @@ -2351,21 +2394,28 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (!is_in(studyName, scope$studies)) { return(list()) } - naAction <- if (is.null(args$naAction)) "drop" else args$naAction + phenotypeFilter <- .jointPhenotypeFilter(args) .jeConcat(map( scope$contexts[[studyName]], .enumTopPcForContext, data = data, scope = scope, args = args, - study = studyName, - naAction = naAction + studyName = studyName, + phenotypeFilter = phenotypeFilter )) } # @noRd -.enumTopPcForContext <- function(cx, data, scope, args, studyName, naAction) { - se <- molecularTraits(data, contexts = cx) +.enumTopPcForContext <- function( + cx, + data, + scope, + args, + studyName, + phenotypeFilter +) { + se <- .qtlContextSe(data, context = cx) traits <- keep( intersect(scope$traits[[studyName]], rownames(se)), .traitSelectedAt, @@ -2381,7 +2431,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { data, contexts = cx, traitId = traits, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = args$residualizationParam ) scores <- .fmTopPcScores(Y, args$nPCs %||% 10L) @@ -2398,7 +2448,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { .enumTopPcGroup, X = X[common, , drop = FALSE], scores = scores[common, , drop = FALSE], - study = studyName, + studyName = studyName, cx = cx )) } @@ -2411,14 +2461,16 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { contexts = cx, traitId = traits, cisWindow = args$cisWindow, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter )) } .fmResidGeno( data, contexts = cx, region = args$region, - residualizationParam = args$residualizationParam + residualizationParam = args$residualizationParam, + genotypeFilter = args$genotypeFilter ) } @@ -2535,7 +2587,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(jointMethods) == 0L || length(parsedJointSpec) == 0L) { return(NULL) } - ldReference <- .jpConfig(pipeline)$ldReference isFm <- is(pipeline, "FmJointPipeline") results <- compact(map( parsedJointSpec, @@ -2551,13 +2602,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(results) == 0L) { return(NULL) } - rbindFn <- if (isFm) .rbindFineMappingResult else .rbindTwasWeights - reduce( - results, - .jointRbindWithLdRef, - rbindFn = rbindFn, - ldReference = ldReference - ) + # Every row keeps the LD reference its group was fitted against. + reduce(results, if (isFm) .rbindFineMappingResult else .rbindTwasWeights) } # `map()` hands the spec first, which is also where .runOneJointSpec wants it. @@ -2584,11 +2630,6 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { ) } -# @noRd -.jointRbindWithLdRef <- function(acc, res, rbindFn, ldReference) { - rbindFn(acc, res, ldReference = ldReference) -} - # Run all joint methods for ONE spec: resolve its scope (optionally # region-restricting the traits), pick the joint cell, and dispatch to # .runJointCell (one call with ALL methods so the twas ensemble layer can @@ -2632,7 +2673,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { if (length(ctxs) == 0L) { return(scope$traits[[st]]) } - se <- molecularTraits(data, contexts = ctxs[[1L]]) + se <- .qtlContextSe(data, context = ctxs[[1L]]) .fmTraitsInRegion( se, intersect(scope$traits[[st]], rownames(se)), @@ -2700,7 +2741,7 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # One per-condition TwasWeightsRow from column `r` of a joint weight matrix. # @noRd .jointColEntry <- function(r, vids, weights, fitParts, cfg) { - twasWeightsRow( + TwasWeightsRow( variantIds = vids, weights = weights[, r], methodFits = fitParts, @@ -2743,20 +2784,22 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { # One joint output record for condition `i`, or NULL when that entry is absent. # traitPos = the bare trait position (NULL when a QtlSumStats caller supplied -# none -> the column is omitted and traitPosition() reports NA). The -# fine-mapping window is NOT recorded: the element's own span is the region -# (section 4.4), and a stored window would go stale under subsetRegion(). +# none -> the column is omitted and traitPosition() reports an empty +# GRanges). region = the window the joint group was analysed over +# (.jointGroupWindow(): an explicit region, else the union of its traits' cis +# windows). # @noRd .jointEntryRecordAt <- function(i, entries, cond, method, grp, data) { e <- entries[[i]] if (is.null(e)) { return(NULL) } + st <- as.character(cond$study[[i]]) ctx <- as.character(cond$context[[i]]) tid <- as.character(cond$trait[[i]]) - tpos <- .traitPosFor(data, ctx, tid) + tpos <- .traitPosFor(data, st, ctx, tid) list( - study = as.character(cond$study[[i]]), + study = st, context = ctx, trait = tid, method = method, @@ -2765,7 +2808,10 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { jointContexts = grp$jc, jointTraits = grp$jt, traitPos = tpos, - region = grp$region + region = grp$region, + # The reference the group was fitted against, so each result row + # keeps it; NULL for an individual-level group. + ldReference = grp$ldReference ) } diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 1d3e38f6..36341743 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -20,7 +20,7 @@ return(unique(as.character(data$study))) } if (is(data, "MultiStudyQtlDataset")) { - indStudies <- names(qtlDatasets(data)) + indStudies <- names(data) ss <- sumStats(data) ssStudies <- if (is.null(ss)) { character(0) @@ -59,7 +59,7 @@ return("sumstats") } if (is(data, "MultiStudyQtlDataset")) { - if (is_in(studyName, names(qtlDatasets(data)))) { + if (is_in(studyName, names(data))) { return("individual") } ss <- sumStats(data) @@ -105,7 +105,7 @@ ))) } if (is(data, "MultiStudyQtlDataset")) { - indDatasets <- qtlDatasets(data) + indDatasets <- as.list(data) ss <- sumStats(data) if (is.null(studyName)) { fromInd <- .spConcat( @@ -137,7 +137,7 @@ # The trait ids present in one context of a QtlDataset. # @noRd .spTraitsInContext <- function(context, data) { - rownames(molecularTraits(data, context)) + rownames(.qtlContextSe(data, context)) } # Traits available in a single individual-level QtlDataset (optionally scoped). @@ -153,18 +153,18 @@ # Checked here rather than left to the accessor: `.spListTraits` answers # "which traits are in this scope", and an absent context is an empty # answer, not an error. The raw slot read this replaced returned NULL for - # an unknown context; molecularTraits() rejects one, so the empty case + # an unknown context; .qtlContextSe() rejects one, so the empty case # has to # be stated instead of falling out of a NULL. if (!is_in(context, contexts(data))) { return(character(0)) } - rownames(molecularTraits(data, context)) + rownames(.qtlContextSe(data, context)) } # Traits across a MultiStudyQtlDataset (individual studies + sumstats). .spListTraitsMultiStudy <- function(data, studyName, context) { - indDatasets <- qtlDatasets(data) + indDatasets <- as.list(data) ss <- sumStats(data) # No study filter: aggregate across every component (individual + sumstats). # Must precede per-study branches so a present sumStats slot does not shadow @@ -719,6 +719,66 @@ parseTraitIds <- function(traitId, data) { if (is.list(entry)) set_names(list(entry), s) else entry } +# The traits a run selects in context `cx` of study `qd`: its share of the +# parsed `traitId` (all of them when the selection leaves the context out), +# else -- when no trait was named at all -- those `region` overlaps, else all. +# @noRd +.contextSelectedTraits <- function(cx, qd, traitId, region) { + se <- .qtlContextSe(qd, context = cx) + ids <- rownames(se) + if (!is.null(traitId)) { + intersect(ids, .selectedTraits(traitId, studyName(qd), cx) %||% ids) + } else if (!is.null(region)) { + rr <- SummarizedExperiment::rowRanges(se) + ids[IRanges::overlapsAny(rr, region)] + } else { + ids + } +} + +# Whether context `cx` of study `qd` has a trait selected. +# @noRd +.contextHasSelectedTraits <- function(cx, qd, traitId, region) { + length(.contextSelectedTraits(cx, qd, traitId, region)) > 0L +} + +# Whether study `qd` has a trait selected in a context it runs on. In a +# multi-study run a study without one sits out, as one with none of its +# contexts selected does, rather than failing the run. +# @noRd +.studyHasSelectedTraits <- function(qd, contexts, traitId, region) { + useCtx <- .selectedContexts(contexts, studyName(qd)) %||% contexts(qd) + any(map_lgl( + useCtx, + .contextHasSelectedTraits, + qd = qd, + traitId = traitId, + region = region + )) +} + +# A multi-study run in which no component has a selected trait is refused: +# each one without sits out, so the run would otherwise come back empty. An +# embedded summary-statistics row counts when the selection keeps it. `cfg` +# is the run's record, carrying the parsed selection and its `region`. +# @noRd +.msAssertTraitsSelected <- function(data, cfg, pipeline) { + inStudies <- map_lgl( + as.list(data), + .studyHasSelectedTraits, + contexts = cfg$contexts, + traitId = cfg$traitId, + region = cfg$region + ) + ss <- sumStats(data) + inSumStats <- !is.null(ss) && + any(.sumStatsRowsSelected(ss, cfg$contexts, cfg$traitId)) + if (!any(inStudies) && !inSumStats) { + abort(glue("{pipeline}(MultiStudyQtlDataset): no traits selected.")) + } + invisible(NULL) +} + # ============================================================================= # Joint-specification dispatchers (merged from former R/jointDispatchers.R) # ============================================================================= @@ -829,7 +889,7 @@ parseTraitIds <- function(traitId, data) { context = as.character(data$context), trait = as.character(data$trait) ) - allDf <- as.data.frame( + allDf <- .sumStatsDf( data, studyName = cols$study[[tupleRows[[1L]]]], context = cols$context[[tupleRows[[1L]]]], @@ -867,7 +927,7 @@ parseTraitIds <- function(traitId, data) { errorLabel ) { i <- tupleRows[[kk]] - d <- as.data.frame( + d <- .sumStatsDf( data, studyName = cols$study[[i]], context = cols$context[[i]], @@ -928,7 +988,7 @@ parseTraitIds <- function(traitId, data) { # Does context `cx` carry trait `tid`? # @noRd .ccContextHasTrait <- function(cx, data, tid) { - is_in(tid, rownames(molecularTraits(data, contexts = cx))) + is_in(tid, rownames(.qtlContextSe(data, context = cx))) } # Scoped contexts in which a trait is present; NULL if fewer than 2. @@ -1019,7 +1079,9 @@ parseTraitIds <- function(traitId, data) { verbose, label, region = NULL, - residualizationParam + residualizationParam, + genotypeFilter, + phenotypeFilter = NULL ) { perTraitContexts <- .crossContextPerTrait( data, @@ -1037,12 +1099,14 @@ parseTraitIds <- function(traitId, data) { tid, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter ) Yres <- .fmResidPheno( data, contexts = perTraitContexts, traitId = tid, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam ) .crossContextAssemble(X, Yres, perTraitContexts, verbose, label, tid) @@ -1094,9 +1158,11 @@ parseTraitIds <- function(traitId, data) { label, studyName, region = NULL, - residualizationParam + residualizationParam, + genotypeFilter, + phenotypeFilter = NULL ) { - se <- molecularTraits(data, contexts = cx) + se <- .qtlContextSe(data, context = cx) # scopedTraits is already region-restricted upstream (.runJointSpecs) when # region mode is used without an explicit traitId. traitsHere <- intersect(scopedTraits, rownames(se)) @@ -1109,14 +1175,23 @@ parseTraitIds <- function(traitId, data) { traitsHere, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter ) allY <- .fmResidPheno( data, contexts = cx, traitId = traitsHere, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam ) + .crossTraitAssemble(allX, allY, traitsHere, se) +} + +# The cross-trait X / Y on the samples they share, keeping only the samples +# observed for every trait; NULL when fewer than two remain at either step. +# @noRd +.crossTraitAssemble <- function(allX, allY, traitsHere, se) { common <- intersect(rownames(allX), rownames(allY)) if (length(common) < 2L) { return(NULL) @@ -1145,7 +1220,8 @@ parseTraitIds <- function(traitId, data) { traitId, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter ) { if (is.null(region)) { .fmResidGeno( @@ -1153,14 +1229,16 @@ parseTraitIds <- function(traitId, data) { contexts = contexts, traitId = traitId, cisWindow = cisWindow, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter ) } else { .fmResidGeno( data, contexts = contexts, region = region, - residualizationParam = residualizationParam + residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter ) } } @@ -1176,7 +1254,7 @@ parseTraitIds <- function(traitId, data) { # The (context, trait) tuples context `cx` contributes. # @noRd .composedTuplesForContext <- function(cx, data, scopedTraits) { - se <- molecularTraits(data, contexts = cx) + se <- .qtlContextSe(data, context = cx) # scopedTraits is region-restricted upstream (.runJointSpecs) if needed. map(intersect(scopedTraits, rownames(se)), .composedTuple, cx = cx) } @@ -1242,7 +1320,9 @@ parseTraitIds <- function(traitId, data) { allTraits, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter, + phenotypeFilter = NULL ) { # 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 @@ -1253,12 +1333,14 @@ parseTraitIds <- function(traitId, data) { allTraits, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter ) resid <- .fmResidPheno( data, contexts = allContexts, traitId = allTraits, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam ) list( @@ -1283,7 +1365,9 @@ parseTraitIds <- function(traitId, data) { verbose, label, region = NULL, - residualizationParam + residualizationParam, + genotypeFilter, + phenotypeFilter = NULL ) { tuples <- .composedTuples(data, scope, studyName, verbose, label) if (is.null(tuples)) { @@ -1297,19 +1381,26 @@ parseTraitIds <- function(traitId, data) { allTraits, cisWindow, region, - residualizationParam + residualizationParam, + genotypeFilter, + phenotypeFilter ) - allX <- sides$X - YresList <- sides$YresList + .composedAlignXy(sides, tuples) +} + +# X and the tuples' Y columns on the samples both sides share, without the +# samples any Y column misses; NULL when fewer than two samples remain. +# @noRd +.composedAlignXy <- function(sides, tuples) { commonSamples <- reduce( - c(list(rownames(allX)), map(YresList, rownames)), + c(list(rownames(sides$X)), map(sides$YresList, rownames)), intersect ) if (length(commonSamples) < 2L) { return(NULL) } - X <- allX[commonSamples, , drop = FALSE] - Y <- .composedYCols(YresList, tuples, commonSamples) + X <- sides$X[commonSamples, , drop = FALSE] + Y <- .composedYCols(sides$YresList, tuples, commonSamples) if (is.null(Y)) { return(NULL) } @@ -1418,7 +1509,9 @@ parseTraitIds <- function(traitId, data) { entry = mergedEntries ), .jointCols(base), - list(ldReference = NULL) + # Merged entries sit on the rows they were keyed to, references and + # all. + list(ldReference = .rowLdRefs(base)) ) exec(QtlFineMappingResult, !!!qfmrArgs) } @@ -1445,7 +1538,7 @@ parseTraitIds <- function(traitId, data) { # by-key / cross-study rebuilds keep the trait position instead of silently # dropping it. There is no `region` counterpart -- the fine-mapping window # retired (section 4.4) because the element's own span is the region and a - # stored window had no correct update rule under subsetRegion(). + # stored window had no correct update rule when variants are narrowed. list( jointStudies = .jointStrCol("jointStudies", df), jointContexts = .jointStrCol("jointContexts", df), @@ -1473,7 +1566,8 @@ parseTraitIds <- function(traitId, data) { reduce(kept, .msRbindNoLd, rbindFn = rbindFn) } -# Accumulate per-study + sumstats results (tracking the embedded LD sketch). +# Accumulate per-study + sumstats results; every row keeps its own LD +# reference (none for an individual-level study's rows). # @noRd .msDriverAccumulate <- function( qtlDatasets, @@ -1489,21 +1583,17 @@ parseTraitIds <- function(traitId, data) { ) ssRes <- if (is.null(sumStats)) NULL else sumStatsFn(sumStats, cfg) if (is.null(ssRes)) { - return(list(out = fromStudies, embeddedLd = NULL)) + return(fromStudies) } - embeddedLd <- ldReference(ssRes) - out <- if (is.null(fromStudies)) { - ssRes - } else { - rbindFn(fromStudies, ssRes, ldReference = embeddedLd) + if (is.null(fromStudies)) { + return(ssRes) } - list(out = out, embeddedLd = embeddedLd) + rbindFn(fromStudies, ssRes) } -# Reconstruct the per-tuple result object from the accumulated rows. -.msDriverPerTuple <- function(out, resultCtor, embeddedLd) { - # ldReference: NULL if all studies were individual-level; the embedded - # sumStats's ldReference otherwise. +# Reconstruct the per-tuple result object from the accumulated rows, each on +# the LD reference it had. +.msDriverPerTuple <- function(out, resultCtor) { ctorArgs <- c( list( study = as.character(out$study), @@ -1513,7 +1603,7 @@ parseTraitIds <- function(traitId, data) { entry = .collectionEntries(out) ), .jointCols(out), - list(ldReference = embeddedLd) + list(ldReference = .rowLdRefs(out)) ) exec(resultCtor, !!!ctorArgs) } @@ -1538,18 +1628,16 @@ parseTraitIds <- function(traitId, data) { pipelineName, noun = "a result" ) { - acc <- .msDriverAccumulate( - qtlDatasets(data), + out <- .msDriverAccumulate( + as.list(data), sumStats(data), perStudyFn, sumStatsFn, cfg, rbindFn ) - out <- acc$out - embeddedLd <- acc$embeddedLd perTupleResult <- if (!is.null(out)) { - .msDriverPerTuple(out, resultCtor, embeddedLd) + .msDriverPerTuple(out, resultCtor) } else { NULL } @@ -1566,7 +1654,7 @@ parseTraitIds <- function(traitId, data) { if (is.null(perTupleResult)) { return(jointResult) } - rbindFn(perTupleResult, jointResult, ldReference = embeddedLd) + rbindFn(perTupleResult, jointResult) } # Synthesize a jointSpecification for the AUTO-DETECTION path (no explicit @@ -1635,7 +1723,7 @@ parseTraitIds <- function(traitId, data) { parsedJointSpec, cfg$data, dataForm = "individual", - pipeline = .fmJointPipeline(cfg, cfg$crossValidationParam, NULL), + pipeline = .fmJointPipeline(cfg, cfg$crossValidationParam), jointMethods = intersect(tokens, c("mvsusie", "fsusie")), contexts = cfg$contexts, traitIds = cfg$traitId, @@ -1645,10 +1733,11 @@ parseTraitIds <- function(traitId, data) { # 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. +# samples to hold out); individual-level data pass the caller's resolved CV +# record. The LD a group is fitted against is the group's own +# (.jointRowsLdRef()), not a setting of the run. # @noRd -.fmJointPipeline <- function(cfg, crossValidationParam, ldReference) { +.fmJointPipeline <- function(cfg, crossValidationParam) { new( "FmJointPipeline", config = list( @@ -1657,8 +1746,7 @@ parseTraitIds <- function(traitId, data) { crossValidationParam = crossValidationParam, verbose = cfg$verbose, fitRetention = cfg$fitRetention, - seed = cfg$seed, - ldReference = ldReference + seed = cfg$seed ) ) } @@ -1677,7 +1765,9 @@ parseTraitIds <- function(traitId, data) { verbose = cfg$verbose, pipCutoffToSkip = cfg$screen, cache = cfg$fineMappingResult, - residualizationParam = cfg$residualizationParam + residualizationParam = cfg$residualizationParam, + genotypeFilter = cfg$genotypeFilter, + phenotypeFilter = cfg$phenotypeFilter ) } @@ -1695,11 +1785,7 @@ parseTraitIds <- function(traitId, data) { parsedJointSpec, cfg$data, dataForm = "sumstats", - pipeline = .fmJointPipeline( - cfg, - .cvResolve(CrossValidationParam()), - ldReference(cfg$data) - ), + pipeline = .fmJointPipeline(cfg, .cvResolve(CrossValidationParam())), jointMethods = intersect(tokens, c("mvsusie", "fsusie")), contexts = cfg$contexts, traitIds = cfg$traitId, @@ -1730,7 +1816,7 @@ parseTraitIds <- function(traitId, data) { methodArgs, cfg ) { - qtlDatasets <- qtlDatasets(cfg$data) + qtlDatasets <- as.list(cfg$data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .fmMultiStudyWarnExcluded(specs$study, qtlDatasets, cfg$verbose) out <- if (length(specs$nonStudy) == 0L) { @@ -1764,11 +1850,21 @@ parseTraitIds <- function(traitId, data) { .fmStudyJointResult <- function(qd, specs, tokens, methodArgs, cfg) { studyCfg <- list_assign( cfg, - data = .qtlApplyFilterOverrides(qd, cfg$genotypeFilterParam) + data = .qtlRestrictSamples(qd, cfg$genotypeFilter$keepSamples) ) .fmDispatchJointSpecsQtlDataset(specs, tokens, methodArgs, studyCfg) } +# A MultiStudyQtlDataset's summary statistics as its joint fits read them: +# with `cfg$cisWindow` laid on the tuples the parsed selection keeps, as the +# per-study recursion has its QtlSumStats run lay it. The joint fits read the +# collection directly rather than recursing, so they lay it here. +# @noRd +.msJointSumStats <- function(ss, cfg, caller) { + rows <- which(.sumStatsRowsSelected(ss, cfg$contexts, cfg$traitId)) + .qssApplyCisWindow(ss, cfg$cisWindow, caller, rows) +} + # Fine-map every spec on the summary-statistics component and rbind onto the # individual-level results `out`. # @noRd @@ -1795,7 +1891,10 @@ parseTraitIds <- function(traitId, data) { parsedJointSpec, tokens, methodArgs, - list_assign(cfg, data = sumStats) + list_assign( + cfg, + data = .msJointSumStats(sumStats, cfg, "fineMappingPipeline") + ) ) if (is.null(ssRes)) { return(out) @@ -1803,7 +1902,7 @@ parseTraitIds <- function(traitId, data) { if (is.null(out)) { return(ssRes) } - .rbindFineMappingResult(out, ssRes, ldReference = ldReference(ssRes)) + .rbindFineMappingResult(out, ssRes) } @@ -1937,8 +2036,7 @@ parseTraitIds <- function(traitId, data) { fitRetention = cfg$fitRetention, standardized = TRUE, verbose = cfg$verbose, - seed = cfg$seed, - ldReference = ldReference(cfg$data) + seed = cfg$seed ) ) .runJointSpecs( @@ -1972,7 +2070,7 @@ parseTraitIds <- function(traitId, data) { methods, cfg ) { - qtlDatasets <- qtlDatasets(cfg$data) + qtlDatasets <- as.list(cfg$data) specs <- .fmSplitStudyAxisSpecs(parsedJointSpec) .twasMultiStudyWarnExcluded(specs$study, qtlDatasets, cfg$verbose) out <- if (length(specs$nonStudy) == 0L) { @@ -2004,7 +2102,7 @@ parseTraitIds <- function(traitId, data) { # @noRd .twasStudyJointResult <- function(qd, specs, tokens, methods, cfg) { setup <- .twasJointSetup( - .qtlApplyFilterOverrides(qd, cfg$genotypeFilterParam), + .qtlRestrictSamples(qd, cfg$genotypeFilter$keepSamples), .twasNormalizeMethods(methods), cfg ) @@ -2044,7 +2142,10 @@ parseTraitIds <- function(traitId, data) { parsedJointSpec, tokens, .twasSumStatsMethodTokens(methods)$methodArgs, - list_assign(cfg, data = sumStats) + list_assign( + cfg, + data = .msJointSumStats(sumStats, cfg, "twasWeightsPipeline") + ) ) if (is.null(ssRes)) { return(out) @@ -2052,7 +2153,7 @@ parseTraitIds <- function(traitId, data) { if (is.null(out)) { return(ssRes) } - .rbindTwasWeights(out, ssRes, ldReference = ldReference(ssRes)) + .rbindTwasWeights(out, ssRes) } @@ -2119,7 +2220,7 @@ parseTraitIds <- function(traitId, data) { if (!length(hit)) { return(NULL) } - .rowParts(r, hit[[1L]]) + .collectionEntry(r, hit[[1L]]) } # The merged FM entry for base row `i`: gather that key's entry from every diff --git a/R/ld.R b/R/ld.R index 6e90a446..99aa904f 100644 --- a/R/ld.R +++ b/R/ld.R @@ -5,7 +5,7 @@ NULL #' @importFrom dplyr distinct arrange #' @noRd orderDedupRegions <- function(df) { - mutate(df, chrom = canonChrom(.data$chrom)) |> + df |> distinct(.data$chrom, .data$start, .keep_all = TRUE) |> arrange(chromOrder(.data$chrom), .data$start) } @@ -175,7 +175,7 @@ extractFilePaths <- function(genomicData, intersectionRows, columnToExtract) { #' #' @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 region A \code{GRanges} window. #' @param completeCoverageRequired If TRUE, error when the region extends beyond #' available LD blocks. #' @return A list with: intersections (LD_file_paths, bimFilePaths), ldMetaData, @@ -193,14 +193,11 @@ regionalLdMeta <- function( vroom(ldReferenceMetaFile), c("chrom", "start", "end", "path") ) |> + mutate(chrom = withChrPrefix(.data$chrom)) |> .ldMetaWidenWholeChrom() |> orderDedupRegions() |> .regionalLdParsePaths() - region <- `names<-`( - parseRegion(region), - c("chrom", "start", "end") - ) |> - orderDedupRegions() + region <- orderDedupRegions(.regionTable(region)) intersectionRows <- findIntersectionRows( genomicData, region$chrom, @@ -335,11 +332,16 @@ resolveLdSource <- function(path) { #' @importFrom vroom vroom #' @noRd resolveGenotypePathForRegion <- function(metaPath, region) { - parsed <- parseRegion(region) + queryChrom <- unique(.regionTable(region)$chrom) + if (length(queryChrom) != 1L) { + abort(glue( + "`region` spans chromosomes {str_flatten(queryChrom, ', ')}; ", + "a genotype file is resolved for one chromosome at a time." + )) + } meta <- as.data.frame(vroom(metaPath, show_col_types = FALSE)) |> `colnames<-`(c("chrom", "start", "end", "path")) |> - mutate(chrom = canonChrom(.data$chrom)) - queryChrom <- canonChrom(parsed$chrom) + mutate(chrom = withChrPrefix(.data$chrom)) matching <- meta[meta$chrom == queryChrom, , drop = FALSE] if (nrow(matching) == 0) { @@ -412,6 +414,246 @@ resolveGenotypePathForRegion <- function(metaPath, region) { .ldIsGenotypeRef(x) || .ldIsMatrixRef(x) } +# ----------------------------------------------------------------------------- +# Per-row LD references +# ----------------------------------------------------------------------------- +# A collection whose rows can sit on different LD references -- summary +# statistics, the fine-mapping results and TWAS weights fit from them, coloc +# results -- keeps each distinct reference ONCE, in a named list in its +# `ldReference` slot, and names each row's entry in an `ldReference` mcols +# column (NA for an LD-free row). Fifty rows on one sketch hold one copy of +# it, in memory and in a saved object alike, and the per-row key travels with +# the rows on subsetting the way every per-row value in mcols does. + +# The per-tuple form of an `ldReference` argument: one reference for every +# tuple, or a list holding one per tuple. What ldReference() returns reads +# the same way -- an empty list is LD-free and a one-entry list is that +# reference for every tuple -- so a collection's references can be handed +# straight to the next one built from it. +# @noRd +.ldRefPerTuple <- function(ldReference, n) { + asList <- is.list(ldReference) && !is.object(ldReference) + if (asList && length(ldReference) <= 1L) { + ldReference <- if (length(ldReference) == 0L) { + NULL + } else { + ldReference[[1L]] + } + asList <- FALSE + } + if (!asList) { + return(rep(list(.asLdRef(ldReference)), n)) + } + if (length(ldReference) != n) { + abort(glue( + "`ldReference` must be one LD reference, or a list with one per ", + "tuple (got {length(ldReference)} for {n} tuple(s))." + )) + } + map(unname(ldReference), .asLdRef) +} + +# Each distinct reference among `perRow` once, named ld1, ld2, ... in order +# of first use, and every row's key into them (NA for an LD-free row). +# @noRd +.ldRefDict <- function(perRow) { + present <- which(!map_lgl(perRow, is.null)) + ids <- .ldRefIdentities(perRow[present]) + firstIdx <- which(!duplicated(ids)) + keys <- str_c("ld", seq_along(firstIdx)) + rowKeys <- replace( + rep(NA_character_, length(perRow)), + present, + keys[match(ids, ids[firstIdx])] + ) + refs <- if (length(firstIdx) == 0L) { + list() + } else { + set_names(perRow[present[firstIdx]], keys) + } + list(refs = refs, keys = rowKeys) +} + +# A content identity per reference, so equal references -- the same object +# handed to every row, or two equal copies -- collapse to one entry. Hashed +# once per distinct object rather than per row: a large LdMatrix shared by +# every row is read once, not once per row. +# @noRd +#' @importFrom rlang hash obj_address +.ldRefIdentities <- function(refs) { + if (length(refs) == 0L) { + return(character(0)) + } + addresses <- map_chr(refs, obj_address) + firstOfAddress <- !duplicated(addresses) + hashes <- map_chr(refs[firstOfAddress], hash) + hashes[match(addresses, addresses[firstOfAddress])] +} + +# Each row's key into its collection's LD references (NA for an LD-free row). +# @noRd +.ldRefKeys <- function(x) { + mcols(x, use.names = FALSE)$ldReference %||% rep(NA_character_, length(x)) +} + +# What a collection reports as its LD references: the entries some row names, +# so a subset does not report the ones its rows left behind. An object saved +# before the references became per-row holds one reference in the slot and no +# key column, and read as a list it would pass for LD-free; it is refused +# instead (one that held NULL was LD-free, and still reads that way). So is +# one saved before the slot was renamed, which holds it as `ldSketch`. +# @noRd +.ldRefsInUse <- function(x) { + if (!methods::.hasSlot(x, "ldReference")) { + .abortSavedLdRef(x) + } + refs <- x@ldReference + if (is.null(refs)) { + return(list()) + } + if (!is.list(refs) || is.object(refs)) { + .abortSavedLdRef(x) + } + .ldRefsUsed(refs, .ldRefKeys(x)) +} + +# @noRd +.abortSavedLdRef <- function(x) { + abort(c( + glue( + "This {class(x)[[1L]]} was saved before LD references became ", + "per-row, so its rows cannot be matched to its reference." + ), + i = "Bring it up to date with `x <- updateObject(x)`." + )) +} + +# The entries of `refs` some key in `keys` names. +# @noRd +.ldRefsUsed <- function(refs, keys) { + used <- refs[is_in(names(refs), keys)] + if (length(used) == 0L) list() else used +} + +# Every row's LD reference, NULL for an LD-free row. +# @noRd +.rowLdRefs <- function(x) { + refs <- ldReference(x) + map(.ldRefKeys(x), .ldRefForKey, refs = refs) +} + +# Result records tagged with the LD reference of the input row they came +# from, so the collection built from them keeps every row on its own +# reference. +# @noRd +.recordsWithLdRef <- function(records, ldReference) { + map(records, list_assign, ldReference = ldReference) +} + +# `x` with every row on `ldReference` -- one reference, or a list with one +# per row -- its references and its rows' keys rebuilt together. The slot is +# written first and the keys second, so the object is only validated once +# the two agree. +# @noRd +#' @importFrom methods slot<- +.withRowLdRefs <- function(x, ldReference) { + dict <- .ldRefDict(.ldRefPerTuple(ldReference, length(x))) + md <- mcols(x, use.names = FALSE) + md[["ldReference"]] <- dict$keys + S4Vectors::`mcols<-`( + `slot<-`(x, "ldReference", check = FALSE, value = dict$refs), + value = md + ) +} + +# `object` as saved before its references became per-row -- one reference, +# or NULL, in the slot and no row key -- brought up to date: that reference +# becomes the slot's one entry and every row is keyed to it (every row is +# LD-free when it held none). An object saved before the slot was renamed +# holds that reference, a panel or NULL, as `ldSketch`; it is moved to +# `ldReference` first. Every reference is brought up to date too +# (.updateLdRefOrKeep()). A collection that keeps no LD references, such as +# a CtwasResult, is returned as it is. +# @noRd +.updateRowLdRefs <- function(object) { + object <- .renameSavedSlots(object, c(ldSketch = "ldReference")) + if (!methods::.hasSlot(object, "ldReference")) { + return(object) + } + old <- methods::slot(object, "ldReference") + if (!is.list(old) || is.object(old)) { + return(.withRowLdRefs(object, .updateLdRefOrKeep(old))) + } + `slot<-`( + object, + "ldReference", + check = FALSE, + value = map(old, .updateLdRefOrKeep) + ) +} + +# A collection's LD reference as saved, brought up to date (.updatePanel()). +# One whose files cannot be read again is kept as saved, with a warning, +# rather than failing the update: the rest of the collection is still worth +# having, and updating again once the files are back finishes the job. +# @noRd +#' @importFrom rlang try_fetch +.updateLdRefOrKeep <- function(ref) { + try_fetch( + .updatePanel(ref), + pecotmrUnreadablePanel = function(cnd) { + warn( + "An LD reference is kept as saved: LD cannot be read from it.", + parent = cnd + ) + .asLdRef(ref) + } + ) +} + +# Row `i`'s LD reference, or NULL for an LD-free row. +# @noRd +.rowLdRef <- function(x, i) { + .ldRefForKey(.ldRefKeys(x)[[i]], ldReference(x)) +} + +# @noRd +.ldRefForKey <- function(key, refs) { + if (is.na(key)) NULL else refs[[key]] +} + +# What is wrong with an LD-reference list and the keys pointing into it, or +# NULL. An entry's name is what a key points at, so an unnamed, blank or +# repeated one leaves a row pointing at nothing, or at two references. +# @noRd +.ldRefDictProblems <- function(refs, keys) { + if (length(refs) > 0L) { + nms <- names(refs) + badNames <- is.null(nms) || + anyNA(nms) || + any(nms == "") || + anyDuplicated(nms) > 0L + if (badNames) { + return("ldReference entries must have unique, non-empty names") + } + bad <- nms[!map_lgl(refs, .ldIsReference)] + if (length(bad) > 0L) { + return(str_c( + "ldReference entries that are not LD references: ", + str_flatten(bad, ", ") + )) + } + } + unknown <- setdiff(keys[!is.na(keys)], names(refs)) + if (length(unknown) == 0L) { + return(NULL) + } + str_c( + "rows name LD reference(s) not in ldReference: ", + str_flatten(unknown, ", ") + ) +} + # 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 @@ -667,6 +909,24 @@ resolveGenotypePathForRegion <- function(metaPath, region) { glue("{source$format} @ {source$path}") } +# The `show()` line for a collection's LD references: the one reference, or +# each by name when the rows use several; `none` when there are none. +# @noRd +.ldRefsLabel <- function(refs, none) { + if (length(refs) == 0L) { + return(none) + } + labels <- map_chr(refs, .ldRefLabel) + if (length(refs) == 1L) { + return(labels[[1L]]) + } + str_c( + length(refs), + " references -- ", + str_flatten(str_c(names(refs), ": ", labels), "; ") + ) +} + # TRUE for anything that can serve as an LD panel. A bare GenotypeHandle # still counts: that is what objects serialised before the slot became an RSE # carry. @@ -721,7 +981,8 @@ resolveGenotypePathForRegion <- function(metaPath, region) { return(.gmRanges(x)) } if (methods::is(x, "RangedSummarizedExperiment")) { - return(SummarizedExperiment::rowRanges(x)) + # A panel built outside pecotmr may spell its chromosomes otherwise. + return(.ucscRanges(SummarizedExperiment::rowRanges(x))) } .genotypeSnpRanges(x, normalizeVariantId(as.character(snpInfo(x)$SNP))) } @@ -761,10 +1022,10 @@ resolveGenotypePathForRegion <- function(metaPath, region) { .repairVariantIds(ids, as.character(mc$A2), as.character(mc$A1)) } -# Per-variant chromosome, canonical (no chr prefix). +# Per-variant chromosome. # @noRd .ldRefChrom <- function(x) { - canonChrom(as.character(GenomicRanges::seqnames(.ldRefRanges(x)))) + as.character(GenomicRanges::seqnames(.ldRefRanges(x))) } # A panel's sample ids. An LdMatrix has no samples, so asking is a bug in the @@ -1225,12 +1486,12 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # 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) +.ldFactorEigen <- function(ldFactor) { + s <- svd(ldFactor, nu = 0L) list( - values = s$d^2 / (nrow(F) - 1), + values = s$d^2 / (nrow(ldFactor) - 1), vectors = s$v, - nNull = ncol(F) - length(s$d) + nNull = ncol(ldFactor) - length(s$d) ) } @@ -1387,7 +1648,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (length(chromPaths) == 0L) { return(.genotypeStem(.resolveGenotypeResourcePath(source$path))) } - spanned <- unique(canonChrom(as.character(chroms))) + spanned <- unique(as.character(chroms)) paths <- unname(chromPaths[is_in(names(chromPaths), spanned)]) .genotypeStem(map_chr(paths, .resolveGenotypeResourcePath)) } @@ -1652,14 +1913,15 @@ resolveGenotypePathForRegion <- function(metaPath, region) { # yields two differently trimmed sketches. Downstream LD lookups are all # id-matched, so a partial overlap is reported (once per session) rather than # refused; no overlap at all is an error. Shared by causalInferencePipeline, -# colocPipeline, qtlEnrichmentPipeline, ctwasPipeline, and colocboostPipeline. +# colocPipeline, qtlEnrichmentPipeline and ctwasPipeline, each over the rows +# it combines (.requireMatchingRowLdRefs()). # # NULL handling: # nullPolicy = "qtl-required" (default): a NULL qtlLd skips the check; a -# non-NULL qtlLd with a NULL gwasLd is an error. Used by cip / coloc / -# ctwas / enloc / qtlEnrichment. +# non-NULL qtlLd with a NULL gwasLd is an error. Used by cip / coloc +# (enloc included) / ctwas. # nullPolicy = "lenient": a NULL on either side skips the check. Used by -# colocboostPipeline. +# qtlEnrichmentPipeline. # # `label` is the human-readable name of the QTL-side input (e.g. # "twasWeights" or "fineMappingResult"); it is woven into the error @@ -1743,7 +2005,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { gr <- .ldRefRanges(x) mc <- S4Vectors::mcols(gr) stem <- str_c( - canonChrom(as.character(GenomicRanges::seqnames(gr))), + as.character(GenomicRanges::seqnames(gr)), ":", as.character(GenomicRanges::start(gr)) ) @@ -1960,6 +2222,188 @@ resolveGenotypePathForRegion <- function(metaPath, region) { invisible(NULL) } +# .requireMatchingLdRefs() for the rows an analysis actually combines: QTL row +# qtlRows[k] with GWAS row gwasRows[k]. Rows on different references are fine +# as long as no combined pair puts two of them together. Each distinct pair of +# references is checked once, and an error names the first rows that combine +# them. +# @noRd +#' @importFrom purrr pwalk +.requireMatchingRowLdRefs <- function( + qtl, + gwas, + qtlRows, + gwasRows, + pipelineName, + label = NULL, + nullPolicy = c("qtl-required", "lenient") +) { + nullPolicy <- arg_match(nullPolicy) + pairs <- distinct( + tibble( + qtlKey = .ldRefKeys(qtl)[qtlRows], + gwasKey = .ldRefKeys(gwas)[gwasRows], + qtlRow = qtlRows, + gwasRow = gwasRows + ), + .data$qtlKey, + .data$gwasKey, + .keep_all = TRUE + ) + pwalk( + pairs, + .requireMatchingPairLdRefs, + qtlRefs = ldReference(qtl), + gwasRefs = ldReference(gwas), + pipelineName = pipelineName, + label = label %||% "qtl input", + nullPolicy = nullPolicy + ) + invisible(NULL) +} + +# @noRd +.requireMatchingPairLdRefs <- function( + qtlKey, + gwasKey, + qtlRow, + gwasRow, + qtlRefs, + gwasRefs, + pipelineName, + label, + nullPolicy +) { + .requireMatchingLdRefs( + .ldRefForKey(qtlKey, qtlRefs), + .ldRefForKey(gwasKey, gwasRefs), + pipelineName = pipelineName, + label = glue("{label} row {qtlRow} (with gwas row {gwasRow})"), + nullPolicy = nullPolicy + ) +} + +# .requireMatchingRowLdRefs() over the QTL / GWAS row pairs whose regions +# overlap: the pairs an analysis that brings the two sides together region by +# region combines. +# @noRd +.requireOverlapLdRefs <- function( + qtl, + gwas, + pipelineName, + label = NULL, + nullPolicy = c("qtl-required", "lenient") +) { + pairs <- .overlappingRowPairs(qtl, gwas) + .requireMatchingRowLdRefs( + qtl, + gwas, + pairs$qtlRows, + pairs$gwasRows, + pipelineName = pipelineName, + label = label, + nullPolicy = nullPolicy + ) +} + +# The (QTL row, GWAS row) pairs whose element spans overlap. Both sides are +# narrowed to the chromosomes they share first: GenomicRanges warns about +# sequence levels the two have no part of in common, which would be noise for +# collections on different chromosomes rather than a sign of anything wrong. +# @noRd +.overlappingRowPairs <- function(qtl, gwas) { + q <- .rowSpans(qtl) + g <- .rowSpans(gwas) + shared <- intersect( + as.character(GenomicRanges::seqnames(q$spans)), + as.character(GenomicRanges::seqnames(g$spans)) + ) + if (length(shared) == 0L) { + return(list(qtlRows = integer(0), gwasRows = integer(0))) + } + qOn <- is_in(as.character(GenomicRanges::seqnames(q$spans)), shared) + gOn <- is_in(as.character(GenomicRanges::seqnames(g$spans)), shared) + hits <- GenomicRanges::findOverlaps( + .onSeqlevels(q$spans[qOn], shared), + .onSeqlevels(g$spans[gOn], shared), + ignore.strand = TRUE + ) + list( + qtlRows = q$rows[qOn][S4Vectors::queryHits(hits)], + gwasRows = g$rows[gOn][S4Vectors::subjectHits(hits)] + ) +} + +# Which of `query`'s ranges overlap any of `subject`'s, compared on the +# chromosomes the two share -- GenomicRanges warns about sequence levels two +# objects have none of in common, which is noise for ranges that simply sit +# on different chromosomes. +# @noRd +.overlapsOnShared <- function(query, subject) { + query <- .locusRanges(query) + subject <- .locusRanges(subject) + qChr <- as.character(GenomicRanges::seqnames(query)) + sChr <- as.character(GenomicRanges::seqnames(subject)) + shared <- intersect(qChr, sChr) + hit <- rep(FALSE, length(query)) + if (length(shared) == 0L) { + return(hit) + } + qOn <- is_in(qChr, shared) + replace( + hit, + qOn, + IRanges::overlapsAny( + .onSeqlevels(query[qOn], shared), + .onSeqlevels(subject[is_in(sChr, shared)], shared) + ) + ) +} + +# Each non-empty row's span, with the row it belongs to. +# @noRd +.rowSpans <- function(x) { + rr <- range(x) + list( + spans = .locusRanges(unlist(rr, use.names = FALSE)), + rows = rep(seq_along(rr), lengths(rr)) + ) +} + +# Where `gr`'s ranges sit, for comparing collections' ranges: strand and +# metadata dropped, the genome build kept, which is what stops ranges of two +# builds from meeting. +# @noRd +#' @importFrom BiocGenerics unstrand +.locusRanges <- function(gr) { + GenomicRanges::granges(unstrand(gr)) +} + +# The one LD reference rows `rows` of `x` share, for an analysis that reads +# their statistics together against one LD matrix. Rows on different +# references are refused rather than read from one of them; `what` names the +# rows in the error. +# @noRd +.rowsSharedLdRef <- function(x, rows, what) { + keys <- unique(.ldRefKeys(x)[rows]) + if (length(keys) > 1L) { + abort(c( + glue("{what} use {length(keys)} different LD references."), + i = str_c( + "Their statistics are read together against one LD matrix; ", + "give them one LD reference." + ) + )) + } + .rowLdRef(x, rows[[1L]]) +} + +# `gr` with exactly the sequence levels `levels`. +# @noRd +.onSeqlevels <- function(gr, levels) { + GenomeInfoDb::keepSeqlevels(gr, levels, pruning.mode = "coarse") +} + # ---------- Variant lookups against an LD reference on disk ---------- #' Filter variants by LD Reference @@ -1993,15 +2437,20 @@ filterVariantsByLdReference <- function( assertFlag(keepIndel) variantsDf <- parseVariantId(variantIds) - # Derive region to scope the reference lookup - regionDf <- variantsDf |> + # The span of the variants on each chromosome scopes the reference lookup. + spans <- variantsDf |> group_by(.data$chrom) |> summarise(start = min(.data$pos), end = max(.data$pos)) # Use shared helper -- no genotype loading - refInfo <- refVariantInfo(ldReferenceMetaFile, regionDf) - refChrom <- canonChrom(refInfo$chrom) - refKey <- str_c(refChrom, ":", refInfo$pos) + refInfo <- refVariantInfo( + ldReferenceMetaFile, + GenomicRanges::GRanges( + spans$chrom, + IRanges::IRanges(spans$start, spans$end) + ) + ) + refKey <- str_c(refInfo$chrom, ":", refInfo$pos) variantKey <- str_c(variantsDf$chrom, ":", variantsDf$pos) inRef <- which(is_in(variantKey, refKey)) @@ -2786,7 +3235,7 @@ enforceDesignFullRank <- function( #' which case bigsnpr falls back to minor allele frequency computed from #' \code{X}. #' @param chr Integer or character vector of length \code{ncol(X)} giving the -#' chromosome for each variant. +#' chromosome for each variant, in any style (\code{"chr1"} or \code{1}). #' @param pos Integer vector of length \code{ncol(X)} giving the base-pair #' position for each variant. #' @param r2 Numeric in (0, 1]. r-squared threshold for clumping (variants @@ -2835,7 +3284,7 @@ ldClumpByScore <- function( G <- .ldClumpFbm(X) keep <- bigsnpr::snp_clumping( G = G, - infos.chr = as.integer(chr), + infos.chr = as.integer(chromOrder(chr)), infos.pos = as.integer(pos), S = score, thr.r2 = r2, @@ -3131,7 +3580,7 @@ ldClumpByScore <- function( #' \code{dimnames} taken from the block where available. #' @examples #' data(qtlSumStatsExample) -#' panel <- ldReference(qtlSumStatsExample) +#' panel <- ldReference(qtlSumStatsExample)[[1L]] #' R <- computeLd(panel, snpIdx = 1:5) #' dim(R) #' # A dosage matrix already in memory is correlated directly. diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index a2f00902..56893088 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -10,8 +10,8 @@ # loadMultiStudyQtlDatasetFromManifest -> MultiStudyQtlDataset # # These are pure readers: they never run summaryStatsQc() (the loaded -# sumstats objects carry qcInfo = list()) and never filter genotypes (the -# QtlDataset QC knobs are stored as lazy slots, applied at extraction time). +# sumstats objects carry qcOptions = list()) and never filter genotypes (that is +# the pipelines' GenotypeFilterParam, applied per extracted block). # # A manifest is either a data.frame or a path to a delimited file. A ".csv" # extension is read with readr::read_csv; anything else is read with @@ -45,6 +45,41 @@ NULL } } +# The windows a BED file holds, as a GRanges. BED's columns are positional -- +# chromosome, start and end, then a name for the window -- and its start is +# 0-based, so it is shifted by one here. Blank, comment, `track` and +# `browser` lines are skipped, and so is a header line naming the columns, +# which LD-block files often have. +# @noRd +.readBedWindows <- function(path, what) { + lines <- discard( + readr::read_lines(path, skip_empty_rows = TRUE, progress = FALSE), + str_detect, + "^(#|track|browser)" + ) + record <- str_detect(lines, "^[^\t]+\t[0-9]+\t[0-9]+(\t|$)") + if (length(lines) > 0L && !record[[1L]]) { + lines <- lines[-1L] + record <- record[-1L] + } + if (length(lines) == 0L || !all(record)) { + abort(glue( + "{what}: '{path}' is not a BED file with windows in it; each ", + "line must give a chromosome, a start and an end, tab-separated." + )) + } + fields <- str_split(lines, "\t", simplify = TRUE) + exec( + GenomicRanges::GRanges, + seqnames = fields[, 1L], + ranges = IRanges::IRanges( + start = as.integer(fields[, 2L]) + 1L, + end = as.integer(fields[, 3L]) + ), + !!!compact(list(blockId = if (ncol(fields) > 3L) fields[, 4L])) + ) +} + # Directory a manifest's relative paths resolve against: the file's own # directory when the manifest was a path, otherwise NULL (paths used as-is). .manifestBase <- function(manifest) { @@ -70,54 +105,6 @@ NULL file.path(base, p) } -# 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 -# .qtlValidateScalars exactly, so this tightens nothing. -# @noRd -#' @importFrom checkmate assertLogical assertNumber assertFlag assertCharacter -.assertQtlPassThrough <- function(scaleResiduals, genotypeFilterParam) { - assertLogical(scaleResiduals, len = 1L) - .assertMethodParam( - genotypeFilterParam, - "GenotypeFilterParam" - ) - # Only what the caller actually set: an unset field defers to QtlDataset's - # own default and has nothing to check here. - walk( - c("mafCutoff", "macCutoff", "xvarCutoff", "imissCutoff"), - .assertQtlFilterNumber, - genotypeFilterParam = genotypeFilterParam - ) - walk( - c("keepSamples", "keepVariants"), - .assertQtlFilterCharacter, - genotypeFilterParam = genotypeFilterParam - ) - if (!is.null(genotypeFilterParam$keepIndel)) { - assertFlag(genotypeFilterParam$keepIndel) - } - invisible(NULL) -} - -# @noRd -.assertQtlFilterNumber <- function(field, genotypeFilterParam) { - v <- genotypeFilterParam[[field]] - if (!is.null(v)) { - assertNumber(v, lower = 0, finite = TRUE, .var.name = field) - } - invisible(NULL) -} - -# @noRd -.assertQtlFilterCharacter <- function(field, genotypeFilterParam) { - v <- genotypeFilterParam[[field]] - if (!is.null(v)) { - assertCharacter(v, .var.name = field) - } - invisible(NULL) -} - #' @importFrom checkmate assertNames # The existing column an alias set points at, or NULL when the canonical name # is already present or nothing matches. @@ -200,6 +187,63 @@ NULL NULL } +# The build a summary-statistics load names: the one given, checked against +# any its GWAS-VCF files record on ##reference, or else theirs. Files that +# disagree, or that disagree with the one given, are refused. +# @noRd +.manifestBuild <- function(genome, recorded, caller) { + if (length(recorded) > 1L) { + abort(glue( + "{caller}: the GWAS-VCF files record different genome builds ", + "({str_flatten(recorded, ', ')})." + )) + } + if (is.null(genome)) { + if (length(recorded) == 1L) { + return(recorded) + } + abort("`genome` must be provided as an argument or a manifest column.") + } + if (length(recorded) == 1L && !identical(as.character(genome), recorded)) { + abort(glue( + "{caller}: `genome` is '{genome}', but the GWAS-VCF files ", + "record '{recorded}'." + )) + } + genome +} + +# The build the manifest's rows are on: the `genome` argument or column, +# reconciled with the builds its GWAS-VCF files record. +# @noRd +.manifestGenome <- function(df, genome, base, caller) { + .manifestBuild( + .reconcileScalar(df[["genome"]], genome, "genome", required = FALSE), + .manifestVcfBuilds(df, base), + caller + ) +} + +# The genome builds the manifest's GWAS-VCF files record, read from their +# headers alone. +# @noRd +.manifestVcfBuilds <- function(df, base) { + paths <- map_chr(as.character(df$sumStatsPath), .resolveRel, base = base) + vcfs <- paths[str_detect(str_to_lower(paths), "\\.vcf(\\.b?gz)?$")] + if (length(vcfs) == 0L) { + return(character(0)) + } + if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { + return(character(0)) + } + unique(discard(map_chr(vcfs, .vcfHeaderBuild), is.na)) +} + +# @noRd +.vcfHeaderBuild <- function(path) { + .vcfMetaBuild(VariantAnnotation::scanVcfHeader(path)) +} + # ============================================================================= # Genotype-format detection + LD-sketch resolution # ============================================================================= @@ -257,56 +301,119 @@ NULL .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 -# `.materializeLdRef` lets the loader first learn which chromosomes the -# summary statistics cover and skip the panel's other per-chromosome shards. -.resolveLdRefInput <- function(df, ldReference, base) { +# The LD sketch SPEC of every manifest row, without reading any genotype +# metadata yet: the `ldReference` argument for all of them, or each row's own +# `ldReferencePath` (resolved against the manifest's directory). Rows may name +# different references; where a row's path and the argument are both given +# they must agree. An already-open panel passed as the argument is returned as +# it is, for every row. Deferring the reads to .manifestRowLdRefs() lets the +# loader first learn which chromosomes each reference's rows cover and skip +# the panel's other per-chromosome shards. +# @noRd +.resolveLdRefSpecs <- function(df, ldReference, base) { + n <- nrow(df) open <- .openLdRef(ldReference) if (!is.null(open)) { - return(open) + return(rep(list(open), n)) } - # 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. ldReferencePath is optional (LD may come via - # `ldReference`). - colSpec <- if (!is_in("ldReferencePath", names(df))) { - NULL - } else { - v <- unique(as.character(df$ldReferencePath[ - !is.na(df$ldReferencePath) & - str_length(as.character(df$ldReferencePath)) > 0L - ])) - if (length(v) > 1L) { - abort( - "`ldReferencePath` column must be constant across the manifest." + paths <- .manifestLdRefPaths(df, base) + given <- !is.na(paths) + if (!is.null(ldReference)) { + agrees <- map_lgl(paths, identical, as.character(ldReference)) + if (any(given & !agrees)) { + msg <- glue( + "`ldReference` argument disagrees with the manifest ", + "`ldReferencePath` column." ) + abort(msg) } - if (length(v) == 1L) .resolveRel(v, base) else NULL + return(rep(list(ldReference), n)) } - spec <- ldReference %||% colSpec - if ( - !is.null(ldReference) && - !is.null(colSpec) && - !identical(as.character(ldReference), as.character(colSpec)) - ) { - msg <- glue( - "`ldReference` argument disagrees with the manifest ", - "`ldReferencePath` column." - ) - abort(msg) - } - if (is.null(spec)) { + if (!any(given)) { msg <- glue( "`ldReference` must be provided as an argument or an ", "`ldReferencePath` column." ) abort(msg) } - spec + if (!all(given)) { + abort(glue( + "every manifest row needs an LD reference: row(s) ", + "{str_flatten(which(!given), ', ')} have no `ldReferencePath`, ", + "and no `ldReference` argument was given." + )) + } + as.list(paths) +} + +# Each manifest row's own `ldReferencePath`, resolved against the manifest's +# directory; NA where the column is absent or the cell blank. is_in guard, +# not `!is.null(df$ldReferencePath)`: on a tibble `$` for an absent column +# NULLs but WARNS ("Unknown or uninitialised column"). +# @noRd +.manifestLdRefPaths <- function(df, base) { + if (!is_in("ldReferencePath", names(df))) { + return(rep(NA_character_, nrow(df))) + } + raw <- as.character(df$ldReferencePath) + keep <- which(!is.na(raw) & str_length(raw) > 0L) + replace( + rep(NA_character_, length(raw)), + keep, + map_chr(raw[keep], .resolveRel, base = base) + ) +} + +# The LD reference of every manifest row. Each distinct spec is read once, +# only for the chromosomes its rows cover, checked for containment against +# its rows with `check` (.checkGwasLdContainment() or +# .qtlSumStatsCheckContainment()), and trimmed to their span; rows on one +# spec share that one reference, so the collection stores it once. +# @noRd +.manifestRowLdRefs <- function(specs, entries, df, minLdOverlapWarn, check) { + keys <- map_chr(specs, .ldSpecKey) + groups <- split(seq_along(specs), factor(keys, levels = unique(keys))) + refs <- map( + groups, + .manifestGroupLdRef, + specs = specs, + entries = entries, + df = df, + minLdOverlapWarn = minLdOverlapWarn, + check = check + ) + unname(refs[match(keys, names(groups))]) +} + +# One spec's reference for the manifest rows naming it. The containment +# checks sit between the read and the trim because containment is only +# answerable once the sketch is read, and trimming would hide a miss. +# @noRd +.manifestGroupLdRef <- function( + rows, + specs, + entries, + df, + minLdOverlapWarn, + check +) { + rowEntries <- entries[rows] + materialized <- .materializeLdRef( + specs[[rows[[1L]]]], + .entriesChroms(rowEntries) + ) + check(materialized, rowEntries, slice(df, rows), minLdOverlapWarn) + .subsetLdRefToRange(materialized, rowEntries) +} + +# A key telling LD reference specs apart: a path, or per-chromosome paths, by +# its text; an already-open reference by the object itself. +# @noRd +.ldSpecKey <- function(spec) { + if (!is.character(spec)) { + return(obj_address(spec)) + } + str_flatten(str_c(names(spec) %||% "", "=", spec), "|") } # Materialise a resolved ldReference spec into a genotype panel, reading only @@ -324,7 +431,7 @@ NULL .resolveLdRef(spec, chroms = chroms) } -# Canonical chromosomes present across a list of sumstats entry GRanges. NULL / +# The chromosomes present across a list of sumstats entry GRanges. NULL / # empty entries contribute nothing; NA seqnames are dropped. Always returns a # character vector (character(0) when nothing is present, never NULL). .entriesChroms <- function(entries) { @@ -338,13 +445,13 @@ NULL # LD-sketch containment check (validation only; no filtering) # ============================================================================= -# Canonical chromosomes present in an LD reference: for a panel read from a +# The 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))) + return(names(chromPaths)) } unique(.ldRefChrom(ldReference)) } @@ -380,9 +487,7 @@ NULL # The entry's chromosomes must all be present in the LD sketch; returns them. # @noRd .ldContainmentCheckChroms <- function(entryGr, ldReference, label) { - reqChrom <- unique(canonChrom( - as.character(GenomicRanges::seqnames(entryGr)) - )) + reqChrom <- unique(as.character(GenomicRanges::seqnames(entryGr))) availChrom <- .ldRefChroms(ldReference) missingChrom <- setdiff(reqChrom, availChrom) if (length(missingChrom) > 0L) { @@ -405,10 +510,7 @@ NULL minLdOverlapWarn, label ) { - keep <- is_in( - canonChrom(as.character(GenomicRanges::seqnames(sketchGr))), - reqChrom - ) + keep <- is_in(as.character(GenomicRanges::seqnames(sketchGr)), reqChrom) # 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 @@ -443,70 +545,25 @@ NULL # Summary-statistic file readers # ============================================================================= -# Coerce a region argument (chr:start-end string, GRanges, or one-row -# data.frame with chrom/start/end) into a GRanges. -.asGRegion <- function(region) { - if (methods::is(region, "GRanges")) { - return(region) - } - if (is.data.frame(region)) { - return(GenomicRanges::GRanges( - seqnames = as.character(region$chrom), - ranges = IRanges::IRanges( - start = as.integer(region$start), - end = as.integer(region$end) - ) - )) - } - if (is.character(region) && length(region) == 1L) { - # "chr1_100_200" is the LD-block / region-id spelling of - # "chr1:100-200". Normalized here so one matcher below handles both - # and the seqname survives verbatim (parseRegion() canonicalizes the - # chromosome, which would drop a "chr" prefix the variants still use). - region <- str_replace( - region, - "^([^:]+)_([0-9,]+)_([0-9,]+)$", - "\\1:\\2-\\3" - ) - m <- str_match(region, "^([^:]+):([0-9,]+)-([0-9,]+)$")[1L, ] - if (is.na(m[[1L]])) { - msg <- glue( - "`region` must be a 'chr:start-end' or 'chr_start_end' ", - "string, a GRanges, or a one-row data.frame with ", - "chrom/start/end." - ) - abort(msg) - } - return(GenomicRanges::GRanges( - seqnames = m[[2L]], - ranges = IRanges::IRanges( - start = as.integer(str_remove_all(m[[3L]], ",")), - end = as.integer(str_remove_all(m[[4L]], ",")) - ) - )) - } - msg <- glue( - "`region` must be a 'chr:start-end' string, a GRanges, or a ", - "one-row data.frame with chrom/start/end." - ) - abort(msg) -} - # Remap a region's seqnames to the seqnames actually present in a tabix file -# (tolerant of chr-prefix differences). Returns NULL when no seqname matches. +# (tolerant of chr-prefix differences), merging windows that overlap so no line +# is read twice. A window on a chromosome the file does not hold reads nothing, +# so it is left out; NULL when no window matches. A genome-wide set of windows +# against a one-chromosome file reads that chromosome's windows. .matchRegionSeqnames <- function(gr, available) { want <- as.character(GenomicRanges::seqnames(gr)) mapped <- map_chr(want, .mlMatchSeqname, available = available) - if (anyNA(mapped)) { + ok <- !is.na(mapped) + if (!any(ok)) { return(NULL) } - GenomicRanges::GRanges( - seqnames = mapped, + GenomicRanges::reduce(GenomicRanges::GRanges( + seqnames = mapped[ok], ranges = IRanges::IRanges( - start = GenomicRanges::start(gr), - end = GenomicRanges::end(gr) + start = GenomicRanges::start(gr)[ok], + end = GenomicRanges::end(gr)[ok] ) - ) + )) } # Read the region of a bgzipped + tabix-indexed delimited file into a @@ -519,7 +576,7 @@ NULL } else { NULL } - gr <- .matchRegionSeqnames(.asGRegion(region), Rsamtools::seqnamesTabix(tf)) + gr <- .matchRegionSeqnames(region, Rsamtools::seqnamesTabix(tf)) emptyDf <- if (!is.null(colLine)) { # A header-only read yields a 0-row tibble with the right columns. readr::read_tsv(I(colLine), show_col_types = FALSE, progress = FALSE) @@ -1006,7 +1063,7 @@ NULL chrom = as.character(GenomicRanges::seqnames(rr)), pos = unname(as.integer(GenomicRanges::start(rr))), SNP = names(rr), - A1 = unname(map_chr(as.list(altList), .mlFirstAlt)), + A1 = .mlFirstAlts(altList), A2 = unname(as.character(VariantAnnotation::ref(vcf))), Z = z$z, z_supplied = z$supplied, @@ -1090,7 +1147,7 @@ NULL if (!is.null(region) && hasTbi) { tf <- Rsamtools::TabixFile(path) gr <- .matchRegionSeqnames( - .asGRegion(region), + region, Rsamtools::seqnamesTabix(tf) ) vcf <- if (is.null(gr)) { @@ -1101,8 +1158,9 @@ NULL } else { if (!is.null(region) && !hasTbi) { msg <- glue( - "{label}: VCF '{path}' is not bgzipped + tabix-indexed; ", - "region ignored, reading the whole file." + "{label}: VCF '{path}' is not bgzipped + tabix-indexed, so ", + "the whole file is read; `which` still selects the variants ", + "kept." ) warn(msg) } @@ -1111,8 +1169,6 @@ NULL .vcfToSumstatDf(vcf, sampleSelect, formatMapping, label) } -# Read one delimited-text sumstats file. Region reads only when a .tbi -# sidecar exists; otherwise the whole file is read and any region is ignored. # --------------------------------------------------------------------------- # Raw-table prefilters. Applied to a sumstats table as read, before # `.resolveSumstatCols()` maps it onto the canonical schema. @@ -1120,7 +1176,7 @@ NULL # Keep only the rows belonging to one trait. A cis-QTL scan writes every gene's # window into a single table (tensorqtl does), so without this a manifest row -# pulls in every other gene too; restricting by `region` only helps when the +# pulls in every other gene too; restricting by `which` only helps when the # file is tabix-indexed, and cis windows of neighbouring genes overlap anyway. # @noRd .filterSumstatsByTrait <- function(df, traitColumn, trait, label) { @@ -1213,6 +1269,10 @@ NULL ) } +# Read one delimited-text sumstats file. Region reads only when a .tbi +# sidecar exists; otherwise the whole file is read, with a warning, and the +# region selects the variants kept further on. +# @noRd .readSumStatsText <- function( path, region, @@ -1227,8 +1287,8 @@ NULL } else { if (!is.null(region) && !hasTbi) { msg <- glue( - "{label}: '{path}' is not tabix-indexed; ", - "region ignored, reading the whole file." + "{label}: '{path}' is not tabix-indexed, so the whole file ", + "is read; `which` still selects the variants kept." ) warn(msg) } @@ -1369,7 +1429,8 @@ NULL ) } -# Read a phenotype BED into an expression matrix (genes x samples) + rowRanges. +# Read a phenotype BED into an expression matrix (genes x samples) + rowRanges, +# their chromosomes in UCSC style whatever the file writes (1, chr1). # @noRd .readPhenotypeBed <- function(bedPath) { bed <- readr::read_tsv( @@ -1401,7 +1462,7 @@ NULL ) rr <- `names<-`( GenomicRanges::GRanges( - seqnames = meta$chrom, + seqnames = withChrPrefix(meta$chrom), ranges = IRanges::IRanges(start = meta$start + 1L, end = meta$end) ), meta$gene_id @@ -1472,7 +1533,6 @@ NULL studyName, base, transposeCov, - qc, genotypesOverride = NULL, genoCovOverride = NULL ) { @@ -1482,7 +1542,7 @@ NULL contexts, .buildOneContextSe, rows = rows, - study = studyName, + studyName = studyName, base = base, transposeCov = transposeCov ), @@ -1496,16 +1556,12 @@ NULL transposeCov, genoCovOverride ) - qtlArgs <- c( - list( - study = studyName, - genotypes = genotypes, - phenotypes = phenotypes, - genotypeCovariates = genoCov - ), - qc + QtlDataset( + studyName = studyName, + genotypes = genotypes, + phenotypes = phenotypes, + genotypeCovariates = genoCov ) - exec(QtlDataset, !!!qtlArgs) } # The SummarizedExperiment for one context: exactly one phenotypePath (+ at most @@ -1631,10 +1687,6 @@ NULL #' a genotype path/prefix; reconciled with a \code{genotypePath} column. #' @param genotypeCovariates A numeric matrix (samples x covariates) or a path #' to a covariate TSV; reconciled with a \code{genotypeCovariatePath} column. -#' @param scaleResiduals Pass-through \code{\link{QtlDataset}} argument. -#' @param genotypeFilterParam Pass-through \code{\link{QtlDataset}} filtering -#' options, built with \code{\link{GenotypeFilterParam}} and stored as lazy -#' QC slots. #' @param transposeCovariates Transpose covariate TSVs (QTLtools layout) before #' treating them as samples-as-rows. #' @return A \code{QtlDataset} object. @@ -1652,13 +1704,10 @@ loadQtlDatasetFromManifest <- function( studyName = NULL, genotypes = NULL, genotypeCovariates = NULL, - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam(), transposeCovariates = FALSE ) { assertString(studyName, null.ok = TRUE) assertFlag(transposeCovariates) - .assertQtlPassThrough(scaleResiduals, genotypeFilterParam) base <- .manifestBase(manifest) df <- .canonManifestCols( .readManifest(manifest), @@ -1669,19 +1718,27 @@ loadQtlDatasetFromManifest <- function( # df[["study"]] (not df$study): study is optional here (it may be passed as # the `study` arg instead), and a tibble `$` on an absent column warns. studyName <- .reconcileScalar(df[["study"]], studyName, "study") - qc <- .msqQcArgs(scaleResiduals, genotypeFilterParam) .buildQtlDatasetFromRows( df, studyName, base, transposeCovariates, - qc, genotypesOverride = genotypes, genoCovOverride = genotypeCovariates ) } -# Aliases shared by the sumstats manifests. +# Aliases shared by the sumstats manifests: the column names a manifest may +# spell its BED-style window coordinates with -- BED's own (`chrom`, +# `chromStart`, `chromEnd`), the short `start` / `end`, and a leading `#` on +# the header's first column. +# @noRd +.BED_ALIASES <- list( + chrom = c("chrom", "#chrom", "chr", "#chr"), + start = c("start", "chromStart"), + end = c("end", "chromEnd") +) + .gwasSumStatsManifestAliases <- list( study = c("study", "study_id", "studyId"), sumStatsPath = c( @@ -1704,7 +1761,8 @@ loadQtlDatasetFromManifest <- function( varY = c("varY", "var_y"), genome = c("genome"), ldReferencePath = c("ldReferencePath", "ld_reference_path", "ld_reference") -) +) |> + c(.BED_ALIASES) .qtlSumStatsManifestAliases <- list( study = c("study", "study_id", "studyId"), @@ -1726,8 +1784,11 @@ loadQtlDatasetFromManifest <- function( nSample = c("nSample", "n_sample"), varY = c("varY", "var_y"), genome = c("genome"), - ldReferencePath = c("ldReferencePath", "ld_reference_path", "ld_reference") -) + ldReferencePath = c("ldReferencePath", "ld_reference_path", "ld_reference"), + traitStart = c("traitStart", "trait_start"), + traitEnd = c("traitEnd", "trait_end") +) |> + c(.BED_ALIASES) # TRUE if study `i` has usable case/control counts OR a total-N scalar, so a # missing per-variant N is acceptable for that study. @@ -1741,47 +1802,43 @@ loadQtlDatasetFromManifest <- function( isTRUE(ccOk) || isTRUE(nOk) } -# Materialise the LD sketch reading only the chromosomes the sumstats -# cover, then run the deferred per-study containment checks and trim to -# 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 -.manifestGwasLdRef <- function( - ldReferenceSpec, - entries, - df, - minLdOverlapWarn -) { - materialized <- .materializeLdRef( - ldReferenceSpec, - .entriesChroms(entries) - ) - .checkGwasLdContainment(materialized, entries, df, minLdOverlapWarn) - .subsetLdRefToRange(materialized, entries) -} - #' @title Load a GwasSumStats collection from a manifest #' @description Build a \code{\link{GwasSumStats}} from a manifest with one row -#' per study. No QC is run (the result carries \code{qcInfo = list()}). Each -#' sumstats file needs a \code{z} column, or \code{beta}+\code{se} from which -#' the Wald z (\code{z = beta/se}) is derived when \code{z} is absent (a -#' supplied \code{z} takes precedence). +#' per study. No QC is run (the result carries empty \code{qcOptions()}). +#' Each sumstats file needs a \code{z} column, or \code{beta}+\code{se} from +#' which the Wald z (\code{z = beta/se}) is derived when \code{z} is absent +#' (a supplied \code{z} takes precedence). #' @param manifest A data.frame or path. Columns (snake_case aliases accepted): #' \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{ldReferencePath}. When a row +#' \code{nSample} (optional study-level total N), \code{varY} (optional), the +#' single-valued \code{genome}, and \code{ldReferencePath}, which may differ +#' between studies (each distinct reference is read once, for the +#' chromosomes its studies cover, and stored once). 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. +#' \code{\link{summaryStatsQc}} fills \code{N} from the scalar. Optional +#' BED-style \code{chrom}/\code{start}/\code{end} columns, with a 0-based +#' \code{start} as in BED, give each study its own window, read and kept as +#' with \code{which}; a manifest that has them cannot also be given +#' \code{which}. #' @param genome Genome build; reconciled with a \code{genome} 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). +#' spec (path/prefix/genoMeta), used for every study; where a row also names +#' an \code{ldReferencePath} the two must agree. Omit it to give each study +#' the reference its \code{ldReferencePath} names. +#' @param which Optional analysis windows shared by every study, typically +#' LD blocks: a \code{GRanges}, or the path of a BED file, read as BED +#' with a 0-based start. Only the variants inside them are read, when the +#' file is tabix-indexed text or a bgzipped + tabixed VCF (otherwise the +#' whole file is read, with a warning), and each study is split into one +#' element per window it has variants in, each window recorded as that +#' element's \code{region}, as \code{\link{GwasSumStats}} does with its +#' \code{region}; a named \code{GRanges} names the blocks. Without +#' windows a genome-wide file splits +#' into one element per chromosome; split by LD block, it has the +#' granularity \code{\link{assembleCtwasInputs}} needs. #' @param minLdOverlapWarn Warn when the fraction of sumstats variants present #' in the LD reference falls below this (default 0.5). #' @param columnMapping Optional default column mapping (a named list/vector, or @@ -1790,11 +1847,6 @@ loadQtlDatasetFromManifest <- function( #' @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 (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. #' @examples #' gwasTsv <- system.file("extdata", "manifests", @@ -1803,59 +1855,161 @@ loadQtlDatasetFromManifest <- function( #' package = "pecotmr"), "protocol_example.LD.chr22") #' manifest <- data.frame(study = "g1", sumStatsPath = gwasTsv) #' loadGwasSumStatsFromManifest(manifest = manifest, genome = "hg38", -#' ldReference = ldStem, region = "chr22:10000000-19000000") +#' ldReference = ldStem, +#' which = GenomicRanges::GRanges("chr22:10000000-19000000")) #' @export loadGwasSumStatsFromManifest <- function( manifest, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, - formatMapping = NULL, - ldBlocks = NULL + formatMapping = NULL ) { base <- .manifestBase(manifest) - df <- .canonManifestCols( - .readManifest(manifest), - .gwasSumStatsManifestAliases, - required = c("study", "sumStatsPath"), - label = "GwasSumStats" - ) - if (anyDuplicated(as.character(df$study))) { - abort("GwasSumStats manifest `study` values must be unique.") - } - genome <- .reconcileScalar(df[["genome"]], genome, "genome") - ldReferenceSpec <- .resolveLdRefInput(df, ldReference, base) + df <- .gwasSumStatsManifest(manifest) + genome <- .manifestGenome(df, genome, base, "loadGwasSumStatsFromManifest") + ldReferenceSpecs <- .resolveLdRefSpecs(df, ldReference, base) ns <- .gwasStudyScalars(df) + windows <- .manifestWindows(df, which, "GwasSumStats") entries <- map( seq_len(nrow(df)), .loadGwasEntry, df = df, base = base, - region = region, + windows = windows, columnMapping = columnMapping, sampleSelect = sampleSelect, formatMapping = formatMapping, ns = ns ) - ldReference <- .manifestGwasLdRef( - ldReferenceSpec, + ldReference <- .manifestRowLdRefs( + ldReferenceSpecs, entries, df, - minLdOverlapWarn + minLdOverlapWarn, + check = .checkGwasLdContainment ) - # Without a block manifest a genome-wide file splits by chromosome, which - # is too coarse for cTWAS; with one, each study becomes one element per LD - # block. The constructor does the splitting either way. + # Without windows a genome-wide file splits by chromosome, which is too + # coarse for cTWAS; with them -- typically LD blocks -- each study becomes + # one element per window. The constructor does the splitting either way. gwasArgs <- list_assign( .gwasSumStatsArgs(df, entries, genome, ldReference, ns), - ldBlocks = ldBlocks + region = .gwasManifestRegion(windows) ) exec(GwasSumStats, !!!gwasArgs) } +# The windows a manifest load reads and keeps: the `which` argument, shared +# by every row, or the manifest's BED-style chrom/start/end columns, one +# window per row. Both is an error, being two answers to one question. +# @noRd +.manifestWindows <- function(df, which, label) { + perRow <- .manifestRowWindows(df, label) + if (!is.null(perRow) && !is.null(which)) { + abort(glue( + "{label} manifest gives each row a window in its ", + "chrom/start/end columns, so `which` cannot give them too." + )) + } + list( + perRow = perRow, + shared = if (!is.null(which)) .asRegionRanges(which, "`which`") + ) +} + +# The window a manifest row reads: its own, else the shared ones. +# @noRd +.manifestWindowFor <- function(i, windows) { + if (!is.null(windows$perRow)) windows$perRow[i] else windows$shared +} + +# The GwasSumStats `region` a load builds: the shared windows, or a list with +# each study's own. +# @noRd +.gwasManifestRegion <- function(windows) { + if (is.null(windows$perRow)) { + return(windows$shared) + } + unname(as.list(GenomicRanges::split( + windows$perRow, + seq_along(windows$perRow) + ))) +} + +# The window each manifest row gives in its chrom/start/end columns, or NULL +# when it has no such columns. +# @noRd +.manifestRowWindows <- function(df, label) { + if (!any(is_in(c("start", "end"), names(df)))) { + return(NULL) + } + .manifestRanges(df, "start", "end", label, "window") +} + +# The trait position each manifest row gives in its traitStart / traitEnd +# columns, on the row's `chrom`, or NULL when it has no such columns. A trait +# sits on the chromosome its window does, so there is no second chromosome +# column. +# @noRd +.manifestTraitPos <- function(df, label) { + if (!any(is_in(c("traitStart", "traitEnd"), names(df)))) { + return(NULL) + } + .manifestRanges(df, "traitStart", "traitEnd", label, "trait position") +} + +# Ranges read from a manifest's BED-style columns: `chrom` plus a start and +# an end column, the start 0-based as in BED. Every row must fill them in. +# The chromosomes come back in UCSC style, as every range read from a file +# does. +# @noRd +.manifestRanges <- function(df, startCol, endCol, label, what) { + need <- c("chrom", startCol, endCol) + absent <- setdiff(need, names(df)) + if (length(absent) > 0L) { + abort(glue( + "{label} manifest: a {what} needs the columns ", + "{str_flatten(need, ', ')}; missing {str_flatten(absent, ', ')}." + )) + } + empty <- which( + is.na(df$chrom) | is.na(df[[startCol]]) | is.na(df[[endCol]]) + ) + if (length(empty) > 0L) { + abort(glue( + "{label} manifest: row(s) ", + "{str_flatten(utils::head(empty, 5L), ', ')} ", + "leave their {what} empty; give every row one, or none." + )) + } + GenomicRanges::GRanges( + withChrPrefix(df$chrom), + IRanges::IRanges( + start = as.integer(df[[startCol]]) + 1L, + end = as.integer(df[[endCol]]) + ) + ) +} + +# A GwasSumStats manifest's rows, its columns under their canonical names, the +# required ones present and one row per study. +# @noRd +.gwasSumStatsManifest <- function(manifest) { + df <- .canonManifestCols( + .readManifest(manifest), + .gwasSumStatsManifestAliases, + required = c("study", "sumStatsPath"), + label = "GwasSumStats" + ) + if (anyDuplicated(as.character(df$study))) { + abort("GwasSumStats manifest `study` values must be unique.") + } + df +} + # Study-level sample-size scalars from the manifest (n_case + n_control, or # n_sample). When present a row need not carry a per-variant N. # @noRd @@ -1882,7 +2036,7 @@ loadGwasSumStatsFromManifest <- function( i, df, base, - region, + windows, columnMapping, sampleSelect, formatMapping, @@ -1900,7 +2054,7 @@ loadGwasSumStatsFromManifest <- function( } .loadSumStatsEntry( .resolveRel(as.character(df$sumStatsPath[[i]]), base), - region, + .manifestWindowFor(i, windows), mapping, sampleSelect, formatMapping, @@ -1960,7 +2114,7 @@ loadGwasSumStatsFromManifest <- function( .loadQtlSumStatsEntries <- function( df, base, - region, + windows, columnMapping, sampleSelect, formatMapping, @@ -1973,7 +2127,7 @@ loadGwasSumStatsFromManifest <- function( .loadQtlSumStatsEntry, df = df, base = base, - region = region, + windows = windows, columnMapping = columnMapping, sampleSelect = sampleSelect, formatMapping = formatMapping, @@ -1992,22 +2146,39 @@ loadGwasSumStatsFromManifest <- function( #' @param manifest A data.frame or path. Columns (snake_case aliases accepted): #' \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{ldReferencePath}. When a row supplies \code{nSample}, +#' tuple-level total N), \code{varY} (optional), the single-valued +#' \code{genome}, and \code{ldReferencePath}, which may differ between rows +#' (each distinct reference is read once, for the chromosomes its rows +#' cover, and stored once). 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.) +#' QTL traits are quantitative.) Optional BED-style +#' \code{chrom}/\code{start}/\code{end} columns, with a 0-based +#' \code{start} as in BED, give each tuple its own window, read and kept as +#' with \code{which}; a manifest that has them cannot also be given +#' \code{which}. Optional \code{traitStart}/\code{traitEnd} columns, on +#' the row's \code{chrom} and 0-based the same way, give the trait's +#' position (\code{traitPos}). #' @param genome Genome build; reconciled with a \code{genome} 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}}. +#' spec, used for every row; where a row also names an +#' \code{ldReferencePath} the two must agree. Omit it to give each row the +#' reference its \code{ldReferencePath} names. +#' @param which Optional analysis window shared by every tuple: a +#' \code{GRanges}, or the path of a BED file, read as BED with a 0-based +#' start. One window only, since a tuple has one: tuples with windows +#' of their own give them in the manifest's columns. Only the variants +#' inside it are read, when the file is tabix-indexed (otherwise the whole +#' file is read, with a warning), and it is each tuple's \code{region} (see +#' \code{\link{QtlSumStats}}). +#' @param minLdOverlapWarn,columnMapping,sampleSelect,formatMapping As for +#' \code{\link{loadGwasSumStatsFromManifest}}. #' @param traitColumn Optional column of the sumstats file naming the trait of #' each row (e.g. \code{"molecular_trait_id"} in a cis-QTL scan, which writes #' every gene into one table). When set, each manifest row keeps only the #' rows whose \code{traitColumn} equals that row's \code{trait}. Without it -#' a multi-trait file loads whole, since \code{region} restriction needs a +#' a multi-trait file loads whole, since \code{which} restriction needs a #' tabix index and neighbouring cis windows overlap regardless. #' @param variantIdAlleles Where to find the alleles when the file has no #' \code{A1}/\code{A2} columns -- a cis-QTL scan reports effect + se against @@ -2028,13 +2199,14 @@ loadGwasSumStatsFromManifest <- function( #' manifest <- data.frame(study = "s1", context = "brain", #' trait = "ENSG1", sumStatsPath = tsv) #' loadQtlSumStatsFromManifest(manifest = manifest, genome = "hg38", -#' ldReference = ldStem, region = "chr22:10000000-19000000") +#' ldReference = ldStem, +#' which = GenomicRanges::GRanges("chr22:10000000-19000000")) #' @export loadQtlSumStatsFromManifest <- function( manifest, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, @@ -2045,13 +2217,14 @@ loadQtlSumStatsFromManifest <- function( variantIdAlleles <- arg_match(variantIdAlleles) base <- .manifestBase(manifest) df <- .qtlSumStatsManifest(manifest) - genome <- .reconcileScalar(df[["genome"]], genome, "genome") - ldReferenceSpec <- .resolveLdRefInput(df, ldReference, base) + genome <- .manifestGenome(df, genome, base, "loadQtlSumStatsFromManifest") + ldReferenceSpecs <- .resolveLdRefSpecs(df, ldReference, base) nSample <- .qtlManifestNSample(df) + windows <- .qtlManifestWindows(df, which) entries <- .loadQtlSumStatsEntries( df, base, - region, + windows, columnMapping, sampleSelect, formatMapping, @@ -2059,11 +2232,12 @@ loadQtlSumStatsFromManifest <- function( traitColumn = traitColumn, variantIdAlleles = variantIdAlleles ) - ldReference <- .manifestQtlLdRef( - ldReferenceSpec, + ldReference <- .manifestRowLdRefs( + ldReferenceSpecs, entries, df, - minLdOverlapWarn + minLdOverlapWarn, + check = .qtlSumStatsCheckContainment ) exec( QtlSumStats, @@ -2073,10 +2247,29 @@ loadQtlSumStatsFromManifest <- function( genome, ldReference, nSample$nSampleCol - ) + ), + region = windows$perRow %||% windows$shared, + traitPos = .manifestTraitPos(df, "QtlSumStats") ) } +# A QTL load's windows (.manifestWindows()). A tuple has one window, so the +# `which` argument, which every tuple shares, must be one; tuples with +# windows of their own give them in the manifest's chrom/start/end columns. +# @noRd +.qtlManifestWindows <- function(df, which) { + windows <- .manifestWindows(df, which, "QtlSumStats") + if (length(windows$shared) > 1L) { + abort(glue( + "loadQtlSumStatsFromManifest(): `which` must be one window, ", + "which every tuple shares (got {length(windows$shared)}). A ", + "tuple with a window of its own gives it in the manifest's ", + "chrom/start/end columns." + )) + } + windows +} + # A QtlSumStats manifest's rows, its columns under their canonical names and # the required ones present. # @noRd @@ -2089,25 +2282,6 @@ loadQtlSumStatsFromManifest <- function( ) } -# 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 # "this tuple needs no per-variant N" flags derived from it: where a row has a # usable nSample, summaryStatsQc fills N from it, so the entry reader's N check @@ -2184,16 +2358,11 @@ loadQtlSumStatsFromManifest <- function( #' \code{study}); one \code{QtlDataset} is built per study group. #' @param sumStatsManifest Optional QtlSumStats manifest (see #' \code{\link{loadQtlSumStatsFromManifest}}). -#' @param genome,ldReference,region,minLdOverlapWarn Passed to the QtlSumStats +#' @param genome,ldReference,which,minLdOverlapWarn Passed to the QtlSumStats #' loader for \code{sumStatsManifest}. #' @param columnMapping,sampleSelect,formatMapping Passed to the QtlSumStats #' loader for \code{sumStatsManifest}. #' @param transposeCovariates Transpose covariate TSVs (QTLtools layout). -#' @param scaleResiduals Pass-through \code{\link{QtlDataset}} argument, -#' applied to every study. -#' @param genotypeFilterParam Pass-through \code{\link{QtlDataset}} filtering -#' options, built with \code{\link{GenotypeFilterParam}} and applied to -#' every study. #' @return A \code{MultiStudyQtlDataset} object. #' @examples #' d <- system.file("extdata", "qtl_mini", package = "pecotmr") @@ -2208,29 +2377,21 @@ loadMultiStudyQtlDatasetFromManifest <- function( sumStatsManifest = NULL, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, formatMapping = NULL, - transposeCovariates = FALSE, - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam() + transposeCovariates = FALSE ) { assertFlag(transposeCovariates) assertNumber(minLdOverlapWarn, lower = 0, upper = 1) - .assertQtlPassThrough(scaleResiduals, genotypeFilterParam) - qc <- .msqQcArgs(scaleResiduals, genotypeFilterParam) - qtlDatasets <- .msqBuildDatasets( - qtlDatasetsManifest, - transposeCovariates, - qc - ) + qtlDatasets <- .msqBuildDatasets(qtlDatasetsManifest, transposeCovariates) sumStats <- .msqLoadSumStats( sumStatsManifest, genome, ldReference, - region, + which, minLdOverlapWarn, columnMapping, sampleSelect, @@ -2239,20 +2400,9 @@ loadMultiStudyQtlDatasetFromManifest <- function( MultiStudyQtlDataset(qtlDatasets = qtlDatasets, sumStats = sumStats) } -# Bundle the per-study QC / sample-filter arguments into a list. What remains -# after GenotypeFilterParam() absorbed the seven filter fields: this is what is -# spliced into QtlDataset(). -# @noRd -.msqQcArgs <- function(scaleResiduals, genotypeFilterParam) { - list( - scaleResiduals = scaleResiduals, - genotypeFilterParam = genotypeFilterParam - ) -} - # Read the qtlDatasets manifest and build one QtlDataset per study. # @noRd -.msqBuildDatasets <- function(qtlDatasetsManifest, transposeCovariates, qc) { +.msqBuildDatasets <- function(qtlDatasetsManifest, transposeCovariates) { base <- .manifestBase(qtlDatasetsManifest) df <- .canonManifestCols( .readManifest(qtlDatasetsManifest), @@ -2267,8 +2417,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( .msqDatasetForStudy, df = df, base = base, - transposeCovariates = transposeCovariates, - qc = qc + transposeCovariates = transposeCovariates ), studies ) @@ -2280,7 +2429,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( sumStatsManifest, genome, ldReference, - region, + which, minLdOverlapWarn, columnMapping, sampleSelect, @@ -2293,7 +2442,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( sumStatsManifest, genome = genome, ldReference = ldReference, - region = region, + which = which, minLdOverlapWarn = minLdOverlapWarn, columnMapping = columnMapping, sampleSelect = sampleSelect, @@ -2303,13 +2452,13 @@ loadMultiStudyQtlDatasetFromManifest <- function( # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# One sumstats entry's canonical chromosomes (empty for NULL / 0-length gr). +# One sumstats entry's chromosomes (empty for NULL / 0-length gr). # @noRd .mlEntryChroms <- function(gr) { if (is.null(gr) || length(gr) == 0L) { return(character(0)) } - canonChrom(as.character(GenomicRanges::seqnames(gr))) + as.character(GenomicRanges::seqnames(gr)) } # The tabix seqname matching query seqname `w` (chr-prefix tolerant); NA if @@ -2326,10 +2475,18 @@ loadMultiStudyQtlDatasetFromManifest <- function( is.na(x) || is.null(x) } -# The first ALT allele (as character) of one VCF row's alt set. +# Each VCF row's first ALT allele, as character: one unlist() of the alt sets +# and an index into it, not an as.list() walk that pulls the rows out one at +# a time (about two seconds on three thousand variants). A row with no ALT +# allele gives NA. # @noRd -.mlFirstAlt <- function(a) { - as.character(a)[[1L]] +.mlFirstAlts <- function(altList) { + n <- lengths(altList) + flat <- as.character(unlist(altList, use.names = FALSE)) + first <- cumsum(n) - n + 1L + out <- rep(NA_character_, length(n)) + out[n > 0L] <- flat[first[n > 0L]] + out } # One QtlSumStats entry for manifest row `i` (per-row columnMapping override). @@ -2338,7 +2495,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( i, df, base, - region, + windows, columnMapping, sampleSelect, formatMapping, @@ -2366,7 +2523,7 @@ loadMultiStudyQtlDatasetFromManifest <- function( } .loadSumStatsEntry( .resolveRel(as.character(df$sumStatsPath[[i]]), base), - region, + .manifestWindowFor(i, windows), mapping, sampleSelect, formatMapping, @@ -2382,12 +2539,11 @@ loadMultiStudyQtlDatasetFromManifest <- function( # One study's QtlDataset from its manifest rows. # @noRd -.msqDatasetForStudy <- function(s, df, base, transposeCovariates, qc) { +.msqDatasetForStudy <- function(s, df, base, transposeCovariates) { .buildQtlDatasetFromRows( df[as.character(df$study) == s, , drop = FALSE], s, base, - transposeCovariates, - qc + transposeCovariates ) } diff --git a/R/mashPipeline.R b/R/mashPipeline.R index 055d4c25..89c27f13 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -926,7 +926,7 @@ MashComponentParam <- function( return(list()) } ctors <- .mashComponentCtors() - .nestedAssertEngines(given, ctors, NULL, "MashComponentParam") + .nestedAssertEngines(given, ctors, "MashComponentParam") imap(given, .nestedElement, ctors = ctors, label = "MashComponentParam") } @@ -2545,20 +2545,29 @@ mergeMashData <- function(resData, oneData) { # lead (max PIP) variant. # @noRd .mashFmrMatrices <- function(obj, coverage) { - rawMe <- marginalEffects(obj) - rawCs <- credibleSets(obj, coverage = coverage) - if (!all(is_in(c("variant_id", "context", "beta", "se"), names(rawMe)))) { + # Both views are ranged; the pivot works on their per-variant columns. + rawMe <- as_tibble( + as.data.frame(S4Vectors::mcols(marginalEffects(obj)), optional = TRUE) + ) + rawCs <- as_tibble( + as.data.frame( + S4Vectors::mcols(credibleSets(obj, coverage = coverage)), + optional = TRUE + ) + ) + cond <- .mashFmrConditionColumn(obj) + if (!all(is_in(c("variant_id", cond, "beta", "se"), names(rawMe)))) { msg <- glue( - "mashInput: marginalEffects() must return variant_id/context/", - "beta/se columns; a fine-mapping result with >= 2 contexts is ", - "required." + "mashInput: marginalEffects() must return variant_id/{cond}/", + "beta/se columns; a fine-mapping result with >= 2 ", + "{if (cond == 'study') 'studies' else 'contexts'} is required." ) abort(msg) } pinned <- .mashFmrMethodPin(rawMe, rawCs) me <- pinned$me cs <- pinned$cs - contexts <- unique(me$context) + contexts <- unique(me[[cond]]) variants <- unique(me$variant_id) empty <- matrix( NA_real_, @@ -2566,15 +2575,23 @@ mergeMashData <- function(resData, oneData) { length(contexts), dimnames = list(variants, contexts) ) - # One (variant, context) cell per long-format row; the rest stay NA. - cell <- cbind(match(me$variant_id, variants), match(me$context, contexts)) + # One (variant, condition) cell per long-format row; the rest stay NA. + cell <- cbind(match(me$variant_id, variants), match(me[[cond]], contexts)) list( b = replace(empty, cell, me$beta), s = replace(empty, cell, me$se), - strongRows = .mashFmrStrongRows(cs, variants) + strongRows = .mashFmrStrongRows(cs, variants, cond) ) } +# The column a fine-mapping result's conditions are read from. A QTL result's +# are its contexts. A GWAS result has no context axis, so its conditions are +# its studies -- as they are for a GwasSumStats. +# @noRd +.mashFmrConditionColumn <- function(obj) { + if (methods::is(obj, "GwasFineMappingResult")) "study" else "context" +} + # A multi-method fine-mapping result would duplicate (variant, context) cells; # pin the first method so the pivot is unambiguous. # @noRd @@ -2595,6 +2612,11 @@ mergeMashData <- function(resData, oneData) { list(me = me, cs = cs) } +# @noRd +.mashKeyNa <- function(v) { + replace(as.character(v), is.na(v), "\u0001NA") +} + # The max-PIP variant among one credible set's rows. # @noRd .mashLeadVariant <- function(rows, cs) { @@ -2602,13 +2624,18 @@ mergeMashData <- function(resData, oneData) { } # Row indices (into `variants`) of each credible set's lead (max PIP) variant. +# A set is named by its condition and its index -- and, for a GWAS study +# fine-mapped block by block, its block, since set indices restart in each. # @noRd -.mashFmrStrongRows <- function(cs, variants) { +.mashFmrStrongRows <- function(cs, variants, cond = "context") { csCol <- names(cs)[str_detect(names(cs), "^cs_")] strongVar <- if ( nrow(cs) > 0L && length(csCol) > 0L && is_in("pip", names(cs)) ) { - grp <- interaction(cs$context, cs[[csCol[[1L]]]], drop = TRUE) + keys <- c(cond, intersect("blockId", names(cs)), csCol[[1L]]) + # NA spelled out: the view NA-fills an axis a row lacks (a QTL row's + # blockId), and interaction() would drop every NA-keyed row. + grp <- interaction(map(as.list(cs[keys]), .mashKeyNa), drop = TRUE) map_chr(split(seq_len(nrow(cs)), grp), .mashLeadVariant, cs = cs) } else { character(0) @@ -2739,7 +2766,8 @@ mergeMashData <- function(resData, oneData) { #' 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). +#' run (the matrix builder rejects un-QC'd SumStats). The conditions are a +#' QTL object's contexts and a GWAS object's studies. #' @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 the strong selection on @@ -2942,7 +2970,7 @@ mashInput <- function( #' \code{\link{parseVariantId}} (with a synthetic-position fallback for ids #' that do not encode coordinates); \code{A1} / \code{A2} / \code{N} are #' placeholders because a Z-only input carries no alleles or sample sizes -#' (mash reads only Z). A pass-through \code{qcInfo} record is set so the +#' (mash reads only Z). Pass-through \code{qcOptions()} are set so the #' result clears the mash QC gate. #' @param z Numeric matrix (variants x conditions). \code{rownames(z)} are #' variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the @@ -2962,7 +2990,7 @@ mashInput <- function( #' @param genome Genome build. Default \code{"GRCh38"}. #' @param n Placeholder per-variant sample size. Default \code{1000}. #' @param a1,a2 Placeholder alleles. Defaults \code{"A"} / \code{"G"}. -#' @param role Tag stored in the \code{qcInfo} record. Default \code{"mash"}. +#' @param role Tag stored in the \code{qcOptions()}. Default \code{"mash"}. #' @return A \code{\link{QtlSumStats}} with one entry per condition (column). #' @importFrom GenomicRanges GRanges #' @importFrom IRanges IRanges @@ -3034,7 +3062,7 @@ qtlSumStatsFromZMatrix <- function( #' @param genome Genome build. Default \code{"GRCh38"}. #' @param n Placeholder per-variant sample size. Default \code{1000}. #' @param a1,a2 Placeholder alleles. Defaults \code{"A"} / \code{"G"}. -#' @param role Tag stored in the \code{qcInfo} record. Default \code{"mash"}. +#' @param role Tag stored in the \code{qcOptions()}. Default \code{"mash"}. #' @return A \code{\link{QtlSumStats}} with one entry per condition (column). #' @seealso \code{\link{qtlSumStatsFromZMatrix}}, \code{\link{mashModelFit}} #' @importFrom GenomicRanges GRanges @@ -3110,7 +3138,7 @@ qtlSumStatsFromBetaMatrix <- function( # Decode chrom/pos from the variant ids, synthesising where they do not # parse. An unparseable id still needs a placeable coordinate: the GRanges # is keyed by the variant id, so the range only has to be unique and -# ordered, not correct. +# ordered, not correct. Chromosomes come out in UCSC style (chr1). # @noRd #' @importFrom rlang try_fetch .qszmCoords <- function(vids) { @@ -3177,7 +3205,7 @@ qtlSumStatsFromBetaMatrix <- function( entry = entries, genome = genome, ldReference = ldReference, - qcInfo = list(role = role, entryAudit = vector("list", nCond)) + qcOptions = list(role = role) ) } @@ -3262,10 +3290,10 @@ qtlSumStatsFromBetaMatrix <- function( ) abort(msg) } - if (length(qcInfo(x)) == 0L) { + if (length(qcOptions(x)) == 0L) { msg <- glue( "mashPipeline: '{role}' SumStats has no QC info ", - "(length(qcInfo(x)) == 0L). ", + "(length(qcOptions(x)) == 0L). ", "Run summaryStatsQc() on the SumStats before passing it to ", "mashPipeline()." ) @@ -3384,8 +3412,11 @@ qtlSumStatsFromBetaMatrix <- function( } else { c("SNP", "Z") } + # One read per context. A GWAS study split by chromosome or LD block is + # several rows of one context (its study), and each read already stitches + # every row of it, so reading once per row would read the study k times. rows <- map( - rowsInBlock, + rowsInBlock[!duplicated(setup$contextCol[rowsInBlock])], .mashContextRow, x = x, setup = setup, @@ -3393,19 +3424,11 @@ qtlSumStatsFromBetaMatrix <- function( resolvedScale = resolvedScale ) contexts <- map_chr(rows, "context") - # A later row overwrites an earlier one sharing a context, as the keyed - # assignment did; the variant order is first-seen across all rows. - lastPerContext <- !duplicated(contexts, fromLast = TRUE) + # The variant order is first-seen across the contexts. list( variantOrder = unique(.mashConcatChr(map(rows, "snps"))), - perContextB = set_names( - map(rows[lastPerContext], "b"), - contexts[lastPerContext] - ), - perContextSe = set_names( - map(rows[lastPerContext], "se"), - contexts[lastPerContext] - ) + perContextB = set_names(map(rows, "b"), contexts), + perContextSe = set_names(map(rows, "se"), contexts) ) } @@ -3440,7 +3463,7 @@ qtlSumStatsFromBetaMatrix <- function( # @noRd .mashRowDf <- function(x, rIdx, setup, requireCols) { if (setup$isQtl) { - as.data.frame( + .sumStatsDf( x, studyName = setup$studyCol[[rIdx]], context = setup$contextCol[[rIdx]], @@ -3448,7 +3471,7 @@ qtlSumStatsFromBetaMatrix <- function( require = requireCols ) } else { - as.data.frame( + .sumStatsDf( x, studyName = setup$studyCol[[rIdx]], require = requireCols diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 272dd66f..9c1027d3 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -79,7 +79,9 @@ #' @return A \code{GRanges} keyed on the QTL variant #' (\code{variant_id, chrom, pos, A1, A2} in \code{mcols()}) with all other #' columns prefixed \code{qtl_} / \code{gwas_}. Zero ranges when there is no -#' allele-aware overlap. Take a table with \code{as.data.frame()}. +#' allele-aware overlap. Take a table with \code{as.data.frame()}. Its +#' \code{seqinfo()} names the genome build the two results name; results +#' naming different builds are refused. #' @seealso \code{\link{topLoci}}, \code{matchVariants} #' @examples #' data(qtlFineMappingLbfExample) @@ -98,6 +100,7 @@ setMethod( "overlapTopLoci", signature("QtlFineMappingResult", "GwasFineMappingResult"), function(qtl, gwas, signalCutoff = 0.025) { + build <- .inputsBuild(list(qtl, gwas), "overlapTopLoci") keyCols <- c("variant_id", "chrom", "pos", "A1", "A2") coordCols <- c("chrom", "pos", "A1", "A2") # mcols() rather than as.data.frame() on the ranges: the join @@ -107,14 +110,20 @@ setMethod( qtlTl <- .overlapTopLociTable(qtl, signalCutoff) gwasTl <- .overlapTopLociTable(gwas, signalCutoff) if (nrow(qtlTl) == 0L || nrow(gwasTl) == 0L) { - return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols)) + return(.withGenome( + .overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols), + build + )) } # Allele-aware correspondence between the unique QTL + GWAS variant # sets. target = GWAS, ref = QTL, so `sign` is the flip applied to the # GWAS side. vmap <- .overlapVariantMap(qtlTl, gwasTl) if (is.null(vmap)) { - return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols)) + return(.withGenome( + .overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols), + build + )) } # No zero-row check on `g`: every gwas_vid in `vmap` is drawn from # gwasTl$variant_id, so once vmap is non-NULL the inner join above @@ -131,7 +140,7 @@ setMethod( intersect(keyCols, names(merged)), setdiff(names(merged), keyCols) ) - .overlapToGRanges(select(merged, all_of(ordered))) + .withGenome(.overlapToGRanges(select(merged, all_of(ordered))), build) } ) @@ -215,7 +224,7 @@ setMethod( } p <- parseVariantId(df$variant_id) gr <- GenomicRanges::GRanges( - seqnames = str_c("chr", p$chrom), + seqnames = p$chrom, ranges = IRanges::IRanges(start = p$pos, width = 1L) ) S4Vectors::`mcols<-`( diff --git a/R/pvalCombineWrappers.R b/R/pvalCombineWrappers.R index 10cfbf11..234d021c 100644 --- a/R/pvalCombineWrappers.R +++ b/R/pvalCombineWrappers.R @@ -121,19 +121,28 @@ pvalHmp <- function(pvals) { abort(msg) } +# poolr's empirical adjustment works out which test it is running from its +# own call, as.character(sys.call()[1]) with any "poolr::" prefix stripped. +# So the test is called as poolr::(...): a function object inlined +# into the call, as exec() would do, names no test and fails there. +# @noRd +#' @importFrom rlang call2 pvalPoolr <- function(pvals, method, R, methodArgs = PoolrOptions()) { if (!requireNamespace("poolr", quietly = TRUE)) { abort("Package 'poolr' is required for this method.") } - fn <- switch( - method, - fisher = poolr::fisher, - stouffer = poolr::stouffer, - invchisq = poolr::invchisq, + if (!is_in(method, c("fisher", "stouffer", "invchisq"))) { .abortUnknownMethod("poolr", method) - ) + } args <- as.list(methodArgs) - exec(fn, pvals, R = .poolrDependence(R, method, args), !!!args)$p + test <- call2( + method, + pvals, + R = .poolrDependence(R, method, args), + !!!args, + .ns = "poolr" + ) + eval(test)$p } # `R` in the form poolr's adjustment reads it. `R` holds the correlations @@ -917,6 +926,6 @@ PvalMethodsParam <- function( return(list()) } ctors <- .pvalMethodCtors() - .nestedAssertEngines(given, ctors, NULL, "PvalMethodsParam") + .nestedAssertEngines(given, ctors, "PvalMethodsParam") imap(given, .nestedElement, ctors = ctors, label = "PvalMethodsParam") } diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index 375fb9d1..b41f89e4 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -166,7 +166,7 @@ QvalueOptions <- function(...) { # fdrThreshold stashed by qtlAssociationPostprocess. Uses the SAME package math # as the correction (p.adjust for the Bonferroni-adjusted per-variant p). .qapSignificanceMask <- function(x, method, threshold = NULL) { - recipe <- qcInfo(x)$associationPostprocess + recipe <- qcOptions(x)$associationPostprocess if (is.null(recipe)) { msg <- glue( "This QtlSumStats was not produced by ", @@ -348,11 +348,10 @@ setMethod( } ) -# Rebuild a QtlSumStats with extra row columns added + a new qcInfo. Column +# Rebuild a QtlSumStats with extra row columns added + new qcOptions. Column # assignment on the S4 subclass itself coerces per-element, so we coerce to a -# plain DFrame, add the columns, and re-wrap (the same rebuild idiom as -# subsetChr). -.qapRebuild <- function(x, newCols, qcInfo) { +# plain DFrame, add the columns, and re-wrap. +.qapRebuild <- function(x, newCols, qcOptions) { # The collection is a GRangesList now, not a DFrame: the per-variant # GRanges are the elements and `newCols` are per-tuple metadata, so the # rebuild keeps the elements as-is and only rewrites mcols. @@ -369,11 +368,11 @@ setMethod( } else { cbind(kept, S4Vectors::DataFrame(added, check.names = FALSE)) } - # Rebuilding from as.list() starts from the elements' own seqinfo, so the + # Rebuilding from the elements starts from their own seqinfo, so the # build is written back explicitly -- it is collection-level state, and # there is no genome slot to carry it any more. built <- .withGenomeBuild( - GenomicRanges::GRangesList(as.list(x)), + .rtlJoinParts(list(x)), TRUE, unique(unname(GenomeInfoDb::genome(x))) ) @@ -382,7 +381,7 @@ setMethod( "QtlSumStats", grl, ldReference = ldReference(x), - qcInfo = qcInfo + qcOptions = qcOptions ) } @@ -442,7 +441,7 @@ setMethod( # annotateSignificance can reproduce significance cheaply (thresholds, # not flags). qc <- list_assign( - qcInfo(x), + qcOptions(x), associationPostprocess = list( fdrThreshold = fdrThreshold, mafCutoff = mafCutoff, diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index ff8a69d7..c2903b1c 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -20,7 +20,7 @@ setClass( #' @title Arguments For The QTL Enrichment Estimator #' @description The algorithmic settings \code{\link{qtlEnrichment}} takes, #' as one checked bundle. Everything else that function accepts --- the two -#' data arguments, \code{numThreads}, \code{seed}, \code{verbose}, and the +#' data arguments, \code{BPPARAM}, \code{seed}, \code{verbose}, and the #' \code{alignNames} switch --- is the pipeline's own business and is not #' settable here. #' @param numGwas Number of GWAS variants used to estimate \code{piGwas}. @@ -81,28 +81,35 @@ QtlEnrichmentParam <- function( #' \itemize{ #' \item \code{gwasFineMappingResult}: the genome-wide outcome collection. #' 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. +#' vector. One PIP vector is built per outcome fit, across all its LD +#' blocks -- keyed by (\code{study}, \code{method}) for a GWAS collection +#' (one trait per study) and by (\code{study}, \code{context}, +#' \code{trait}, \code{method}) for a QTL one, since a variant's PIP +#' differs between molecular traits and between fine-mapping methods, and +#' pooling them would collide. #' \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. +#' (\code{study}, \code{context}, \code{method}) -- per (\code{study}, +#' \code{method}) for a GWAS collection, which has no context axis -- so +#' each method's fits make their own estimate rather than counting every +#' region once per method. #' } +#' Both sides' fits are read whole, so a row narrowed since its fit warns +#' (condition class \code{pecotmrFitCoverage}). #' -#' @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. +#' @section LD reference compatibility check: Every row of a GWAS outcome +#' collection must have an \code{ldReference} (it should be RSS-derived). +#' For each QTL row and GWAS row whose regions overlap, where both carry +#' one, the two must be the same LD reference; rows that never overlap may +#' sit on different references. #' 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. +#' its own surviving variants, and a partial overlap only warns. A row with +#' no reference on either side (an individual-level fit) skips the check. #' #' @param gwasFineMappingResult The outcome side; see above. #' @param qtlFineMappingResult The annotation side; see above. @@ -111,17 +118,19 @@ QtlEnrichmentParam <- function( #' \code{lambda}, \code{impN}, \code{doubleShrinkage} and #' \code{besselCorrection}. A bare list is refused, since it cannot be #' checked. -#' @param numThreads Number of threads used by \code{qtlEnrichment}. Default -#' \code{1}. +#' @param BPPARAM A \code{BiocParallelParam} handed to +#' \code{\link{qtlEnrichment}}, whose multiple-imputation threads number +#' its workers. Default \code{SerialParam()}. #' @param seed Integer or \code{NULL}. Base random seed forwarded to #' \code{\link{qtlEnrichment}} for reproducible multiple imputation. #' \code{NULL} (default) draws a nondeterministic seed. #' @param verbose Logical. Print progress messages. Default \code{TRUE}. -#' @return A tibble with one row per (outcome trait, annotation unit) pair. +#' @return A tibble with one row per (outcome fit, annotation unit) pair. #' The identity columns are \code{gwasStudy}, \code{gwasContext}, -#' \code{gwasTrait}, \code{qtlStudy}, \code{qtlContext}; the axes a side does -#' not have are \code{NA} (\code{gwasContext} / \code{gwasTrait} for a GWAS -#' outcome, \code{qtlContext} for a GWAS annotation). Suitable as the +#' \code{gwasTrait}, \code{gwasMethod}, \code{qtlStudy}, \code{qtlContext}, +#' \code{qtlMethod}; the axes a side does not have are \code{NA} +#' (\code{gwasContext} / \code{gwasTrait} for a GWAS outcome, +#' \code{qtlContext} for a GWAS annotation). Suitable as the #' \code{enrichment} argument to \code{\link{colocPipeline}}, which joins on #' those columns. #' @@ -151,11 +160,12 @@ qtlEnrichmentPipeline <- function( gwasFineMappingResult, qtlFineMappingResult, qtlEnrichmentParam = QtlEnrichmentParam(), - numThreads = 1L, + BPPARAM = SerialParam(), seed = NULL, verbose = TRUE ) { .assertMethodParam(qtlEnrichmentParam, "QtlEnrichmentParam") + .assertBpparam(BPPARAM) .enrValidateInputs(gwasFineMappingResult, qtlFineMappingResult) prep <- .enrPrepare(gwasFineMappingResult, qtlFineMappingResult) gwasTuples <- prep$gwasTuples @@ -168,7 +178,7 @@ qtlEnrichmentPipeline <- function( qtlRegionsByTuple = prep$qtlRegionsByTuple, alignedByTuple = alignedByTuple, qtlEnrichmentParam = qtlEnrichmentParam, - numThreads = numThreads, + BPPARAM = BPPARAM, seed = seed, verbose = verbose, gwasFineMappingResult = gwasFineMappingResult, @@ -189,24 +199,27 @@ qtlEnrichmentPipeline <- function( fmrClasses <- c("GwasFineMappingResult", "QtlFineMappingResult") assertMultiClass(gwasFineMappingResult, fmrClasses) assertMultiClass(qtlFineMappingResult, fmrClasses) - outcomeLd <- ldReference(gwasFineMappingResult) + ldFree <- is.na(.ldRefKeys(gwasFineMappingResult)) if ( - is.null(outcomeLd) && + any(ldFree) && methods::is(gwasFineMappingResult, "GwasFineMappingResult") ) { msg <- glue( - "qtlEnrichmentPipeline: the GwasFineMappingResult must have a ", - "non-NULL ldReference (it should be RSS-derived)." + "qtlEnrichmentPipeline: every GwasFineMappingResult row must have ", + "an ldReference (it should be RSS-derived); {sum(ldFree)} of ", + "{length(ldFree)} have none." ) 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. - .requireMatchingLdRefs( - ldReference(qtlFineMappingResult), - outcomeLd, + # Per row pair, over the QTL and GWAS rows whose regions overlap -- the + # ones the enrichment combines. 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. + .requireOverlapLdRefs( + qtlFineMappingResult, + gwasFineMappingResult, pipelineName = "qtlEnrichmentPipeline", + label = "qtlFineMappingResult", nullPolicy = "lenient" ) invisible(NULL) @@ -227,6 +240,11 @@ qtlEnrichmentPipeline <- function( ) abort(msg) } + # Each row's fit is read whole, so a row narrowed since its fit warns. + .fitCoverageCheckedAll( + list(gwasFineMappingResult, qtlFineMappingResult), + "qtlEnrichmentPipeline()" + ) gwasPipByTuple <- map( seq_len(nrow(gwasTuples)), .enrGwasPipForRow, @@ -254,27 +272,32 @@ qtlEnrichmentPipeline <- function( ) } -# The outcome side's per-trait keys: one PIP vector is built per key. A GWAS +# The outcome side's per-fit keys: one PIP vector is built per key. A GWAS # collection carries one trait per study, so its QTL-only axes read NA and the -# key collapses to (study). +# key collapses to (study, method). The method is part of it: two methods' +# fits of one trait are two PIP vectors, and pooling them would put two +# different PIPs on every variant. # @noRd .enrOutcomeTuples <- function(fmr) { distinct(tibble( gwasStudy = .fmrIdentityColumn(fmr, "study"), gwasContext = .fmrIdentityColumn(fmr, "context"), - gwasTrait = .fmrIdentityColumn(fmr, "trait") + gwasTrait = .fmrIdentityColumn(fmr, "trait"), + gwasMethod = .fmrIdentityColumn(fmr, "method") )) } -# The annotation side's keys: (study, context), the unit whose region fits are -# pooled into one enrichment estimate. The joint key matters -- context alone -# would silently merge two studies sharing a context label -- and a GWAS -# annotation pools its blocks under one NA-context key. +# The annotation side's keys: (study, context, method), the unit whose region +# fits are pooled into one enrichment estimate. The joint key matters -- +# context alone would silently merge two studies sharing a context label, and +# without the method each region would count once per method that fit it -- +# and a GWAS annotation pools its blocks under one NA-context key. # @noRd .enrAnnotationTuples <- function(fmr) { distinct(tibble( qtlStudy = .fmrIdentityColumn(fmr, "study"), - qtlContext = .fmrIdentityColumn(fmr, "context") + qtlContext = .fmrIdentityColumn(fmr, "context"), + qtlMethod = .fmrIdentityColumn(fmr, "method") )) } @@ -285,7 +308,8 @@ qtlEnrichmentPipeline <- function( list( study = gwasTuples$gwasStudy[[k]], context = gwasTuples$gwasContext[[k]], - trait = gwasTuples$gwasTrait[[k]] + trait = gwasTuples$gwasTrait[[k]], + method = gwasTuples$gwasMethod[[k]] ) } @@ -293,7 +317,8 @@ qtlEnrichmentPipeline <- function( .enrAnnotationIdent <- function(qtlTuples, k) { list( study = qtlTuples$qtlStudy[[k]], - context = qtlTuples$qtlContext[[k]] + context = qtlTuples$qtlContext[[k]], + method = qtlTuples$qtlMethod[[k]] ) } @@ -347,7 +372,7 @@ qtlEnrichmentPipeline <- function( qtlRegionsByTuple, alignedByTuple = alignedByTuple, qtlEnrichmentParam, - numThreads, + BPPARAM, seed, verbose, gwasFineMappingResult = gwasFineMappingResult, @@ -373,7 +398,7 @@ qtlEnrichmentPipeline <- function( qtlRegionsByTuple = qtlRegionsByTuple, alignedByTuple = alignedByTuple, qtlEnrichmentParam = qtlEnrichmentParam, - numThreads = numThreads, + BPPARAM = BPPARAM, seed = seed, verbose = verbose, gwasFineMappingResult = gwasFineMappingResult, @@ -393,7 +418,7 @@ qtlEnrichmentPipeline <- function( qtlRegionsByTuple, alignedByTuple = alignedByTuple, qtlEnrichmentParam, - numThreads, + BPPARAM, seed, verbose, gwasFineMappingResult = gwasFineMappingResult, @@ -416,7 +441,7 @@ qtlEnrichmentPipeline <- function( k, alignedByTuple = alignedByTuple, qtlEnrichmentParam = qtlEnrichmentParam, - numThreads = numThreads, + BPPARAM = BPPARAM, seed = seed, verbose = verbose, gwasFineMappingResult = gwasFineMappingResult, @@ -461,7 +486,7 @@ qtlEnrichmentPipeline <- function( k, alignedByTuple, qtlEnrichmentParam, - numThreads, + BPPARAM, seed, verbose, gwasFineMappingResult, @@ -482,7 +507,7 @@ qtlEnrichmentPipeline <- function( qtlEnrichment, gwasPip = gwasPip, susieQtlRegions = aligned, - numThreads = numThreads, + BPPARAM = BPPARAM, seed = seed, verbose = verbose, alignNames = FALSE, @@ -517,7 +542,15 @@ qtlEnrichmentPipeline <- function( # annotation unit's. # @noRd .enrIdCols <- function() { - c("gwasStudy", "gwasContext", "gwasTrait", "qtlStudy", "qtlContext") + c( + "gwasStudy", + "gwasContext", + "gwasTrait", + "gwasMethod", + "qtlStudy", + "qtlContext", + "qtlMethod" + ) } # The empty enrichment result table, with the same columns a populated one has. @@ -558,19 +591,20 @@ qtlEnrichmentPipeline <- function( return(NULL) } pip <- as.numeric(fit$pip) - ids <- names(fit$pip) %||% .fmrPartsVariantIds(parts) + ids <- names(fit$pip) %||% .partsFitIds(parts) if (length(ids) != length(pip)) { return(NULL) } 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. +# Build a named outcome PIP vector for one fit. Walks every row of the +# collection carrying that identity -- the fit's LD blocks -- 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 fit tuple: pooling two +# molecular traits of one study, or two methods' fits of one trait, would +# collide on every variant they share. #' @importFrom dplyr add_count #' @noRd .enrBuildGwasPipVector <- function(gwasFmr, ident) { @@ -628,7 +662,7 @@ qtlEnrichmentPipeline <- function( # One row's region payload for qtlEnrichment, or NULL when the row lacks a # fit, an alpha, PIPs, or a prior variance. The PIP names fall back to the -# row's own variant ids when the fit did not carry any. +# ids the fit was made with when the fit did not carry any. # @noRd .enrRowRegion <- function(i, qtlFmr) { parts <- .fmrRowParts(qtlFmr, i) @@ -644,7 +678,7 @@ qtlEnrichmentPipeline <- function( alpha = fit$alpha, pip = set_names( fit$pip, - names(fit$pip) %||% .fmrPartsVariantIds(parts) + names(fit$pip) %||% .partsFitIds(parts) ), prior_variance = priorVariance ) @@ -764,8 +798,10 @@ qtlEnrichmentPipeline <- function( #' When it is set to 0, no shrinkage will be applied. A large value indicates #' strong shrinkage. The default value is set to 1.0. #' @param impN Rounds of multiple imputation to draw QTL from, default is 25. -#' @param numThreads Number of Simultaneous running CPU threads for multiple -#' imputation, default is 1. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the threads +#' the multiple imputation runs on when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' thread. Default \code{SerialParam()}. #' @param alignNames Logical; when TRUE (default) QTL pip names are aligned to #' the GWAS variant-naming convention via \code{matchVariants}. Set FALSE when #' the caller has already aligned them (e.g. \code{qtlEnrichmentPipeline} @@ -818,11 +854,10 @@ qtlEnrichmentPipeline <- function( #' # Set other parameters #' impN <- 10 #' lambda <- 1 -#' numThreads <- 1 #' library(pecotmr) #' en <- qtlEnrichment( #' gwasPip, susieFits, lambda = lambda, impN = impN, -#' numThreads = numThreads) +#' BPPARAM = BiocParallel::SerialParam()) #' #' @seealso \code{\link[susieR]{susie}} #' @useDynLib pecotmr, .registration = TRUE @@ -837,11 +872,12 @@ qtlEnrichment <- function( impN = 25, doubleShrinkage = FALSE, besselCorrection = TRUE, - numThreads = 1, + BPPARAM = SerialParam(), verbose = TRUE, alignNames = TRUE, seed = NULL ) { + .assertBpparam(BPPARAM) piGwas <- .enrEstimatePiGwas(gwasPip, numGwas, verbose) piQtl <- .enrEstimatePiQtl(susieQtlRegions, piQtl, verbose) .enrValidatePi(piGwas, piQtl) @@ -860,7 +896,7 @@ qtlEnrichment <- function( shrinkageLambda = lambda, doubleShrinkage = doubleShrinkage, besselCorrection = besselCorrection, - numThreads = as.integer(numThreads), + numThreads = .bpLocalThreads(BPPARAM, "qtlEnrichment"), seed = if (is.null(seed)) NULL else as.integer(seed) ) list_assign(en, unused_xqtl_variants = unmatchedVariants) diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index ac68c7b9..88c6cecf 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -1,12 +1,13 @@ # ============================================================================= # QtlSumStats S4 class # ----------------------------------------------------------------------------- -# DFrame-subclass collection keyed by the identity tuple (study, context, +# RangedTupleList 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 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. +# (variant_id + per-variant Z/N/MAF mcols). The genome build applies +# uniformly across rows; the ldReference slot holds each distinct LD +# reference once and the ldReference mcols column names the one every row +# uses. The qcOptions slot records the summaryStatsQc() options that ran, and +# the qcAudit column what QC did to each row. # ============================================================================= #' @include AllClasses.R tupleSelectors.R @@ -18,10 +19,21 @@ NULL #' per-variant \code{GRanges} -- \code{variant_id} plus the per-variant #' 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{ldReference}, \code{genome} and -#' \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records -#' which \code{\link{summaryStatsQc}} passes have run. +#' the 3-tuple is unique. The constructor also adds each tuple's analysis +#' window: \code{region}, a \code{GRanges} with one range per element, and +#' \code{regionGiven}, \code{TRUE} where the window was given as a +#' \code{region} and \code{FALSE} where it is the span of the tuple's +#' variants when the collection was first built, before any QC. A QC pass +#' carries both unchanged; the span of the variants left is +#' \code{range(x)}. An optional \code{traitPos} gives the trait's own +#' coordinates, from which a pipeline's \code{cisWindow} derives a cis +#' window. The class-level slots inherited from +#' \code{\linkS4class{SumStatsBase}} -- \code{genome} and +#' \code{qcOptions} -- apply uniformly to every row, and \code{qcOptions} +#' records the \code{\link{summaryStatsQc}} options that ran (what QC did +#' to each row is \code{\link{qcInfo}}); \code{ldReference} holds +#' each distinct LD reference once, and the \code{ldReference} column names +#' the one each row uses. #' @seealso \code{\link{QtlSumStats}} for the constructor and #' \code{\linkS4class{GwasSumStats}} for the GWAS counterpart. #' @export @@ -82,7 +94,8 @@ setClass( #' @title QTL Summary Statistics Handling #' @description Constructor and accessor methods for \code{QtlSumStats}, the -#' DFrame-subclass collection keyed by \code{(study, context, trait)}. +#' \code{RangedTupleList} collection keyed by \code{(study, context, +#' trait)}. #' @name pecotmr-qtl-sumstats #' @keywords internal #' @importFrom GenomicRanges GRanges seqnames start @@ -95,24 +108,25 @@ 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 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}, -#' \code{P}). +#' @description Construct a \code{QtlSumStats} S4 collection from per-tuple +#' vectors and a list of \code{GRanges} entries (one per tuple), plus the LD +#' reference(s) the rows were harmonized against and a single genome build +#' that applies 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}, \code{P}). #' @param studyName Character vector of study identifiers (per tuple). #' @param context Character vector of context labels (per tuple). #' @param trait Character vector of trait identifiers (per tuple). #' @param entry A list / \code{SimpleList} of \code{GRanges}, one per tuple. #' 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 reference. +#' \code{"hg19"}, \code{"hg38"}). One build per collection. #' @param ldReference The LD reference: a genotype panel (see #' \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an -#' \code{\link{LdMatrix}}. +#' \code{\link{LdMatrix}}, used for every tuple, or a list with one per +#' tuple when they sit on different references. Each distinct reference is +#' stored once, and the \code{ldReference} column names each row's. #' @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 @@ -122,18 +136,30 @@ NULL #' \code{nSamples()} (the LD-panel sample size). Unlike GWAS, QTL #' collections carry no case/control counts (molecular traits are #' quantitative), so only this total-N fallback is exposed. -#' @param extraCols Optional named list of additional per-tuple columns to +#' @param extraCols Optional named list (or \code{DataFrame} / +#' \code{data.frame}) of additional per-tuple columns to #' attach to the collection's \code{mcols}. Named rather than variadic #' because the base class's own constructor, \code{GRangesList(...)}, uses #' \code{...} for its \emph{elements}: a bare \code{...} here would read #' as adding an entry rather than a metadata column. -#' @param qcInfo A \code{list} recording which QC steps ran. Empty \code{list()} -#' on construction; populated by \code{summaryStatsQc()} with a per-step audit -#' record. Fine-mapping / TWAS pipelines reject inputs where -#' \code{length(qcInfo(x)) == 0}. +#' @param qcOptions A \code{list} recording the QC that ran. Empty +#' \code{list()} on construction; \code{summaryStatsQc()} fills it. +#' Fine-mapping / TWAS pipelines reject inputs where +#' \code{length(qcOptions(x)) == 0}. #' @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. +#' \code{NULL} (default) omits the column. A pipeline given a +#' \code{cisWindow} analyses each tuple over \code{traitPos} \eqn{\pm} +#' \code{cisWindow}. +#' @param region Optional analysis window of each tuple: a \code{GRanges}, +#' or the path of a BED file, read as BED with a 0-based start. One window +#' for every tuple, or one per tuple. A tuple's variants outside its window +#' are dropped with a warning, and its \code{region} is the window, +#' recorded as given in \code{regionGiven}. Without it, a tuple's +#' \code{region} is the span of its variants as built, before any QC. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{QtlSumStats} object. #' @examples #' panel <- readGenotypes( @@ -153,9 +179,11 @@ QtlSumStats <- function( ldReference = NULL, varY = NA_real_, nSample = NULL, - qcInfo = list(), + qcOptions = list(), traitPos = NULL, - extraCols = list() + region = NULL, + extraCols = list(), + metadata = list() ) { if ( missing(studyName) || @@ -165,33 +193,231 @@ QtlSumStats <- function( missing(genome) ) { msg <- glue( - "`study`, `context`, `trait`, `entry`, and `genome` ", + "`studyName`, `context`, `trait`, `entry`, and `genome` ", "are all required." ) abort(msg) } n <- length(studyName) varY <- .qssValidateArgs(context, trait, entry, genome, varY, n) - entry <- .qssAddTraitDistances(entry, traitPos, n) + windows <- .qssWindows(region, n) + entry <- .qssWithinWindows(.ucscEntries(entry), windows) |> + .qssAddTraitDistances(traitPos, n) cols <- .qssBaseCols(studyName, context, trait, varY) |> .qssAppendNSample(nSample, n) |> .appendTraitPosCol(traitPos, n) |> .qssAppendExtras(extraCols) - dfArgs <- c(cols, list(check.names = FALSE)) - # The per-tuple GRanges become the collection's ELEMENTS; the tuple keys - # and per-tuple scalars go in mcols. There is no `entry` column. - # mcols are attached to the GRangesList BEFORE new(), because new() - # validates during initialize() and the validity method needs the identity - # columns to already be there. - # A multi-seqname entry (e.g. a genome-wide GWAS) is split into one - # element per chromosome, with its metadata row replicated alongside. + dict <- .ldRefDict(.ldRefPerTuple(ldReference, n)) + dfArgs <- c(cols, list(ldReference = dict$keys, check.names = FALSE)) split <- .rtlSplitBySeqname(entry) - md <- exec(S4Vectors::DataFrame, !!!dfArgs) + pieces <- .rtlBindElements(split$entry) grl <- S4Vectors::`mcols<-`( - GenomicRanges::GRangesList(split$entry), - value = md[split$fromIdx, , drop = FALSE] + pieces, + value = .qssPieceMetadata(dfArgs, split, pieces, windows) + ) + .withMetadata( + .sumStatsNewValidated("QtlSumStats", grl, dict$refs, genome, qcOptions), + metadata + ) +} + +# Each piece's metadata row, its tuple's, with the tuple's analysis window: +# the `region` it was given, else the span of its variants as built, before +# any QC. `regionGiven` records which. +# +# The per-tuple GRanges become the collection's ELEMENTS; the tuple keys and +# per-tuple scalars go in mcols. There is no `entry` column. mcols are +# attached to the GRangesList BEFORE new(), because new() validates during +# initialize() and the validity method needs the identity columns to already +# be there. A multi-seqname entry (e.g. a trans tuple) is split into one +# element per chromosome, with its metadata row replicated alongside. +# @noRd +.qssPieceMetadata <- function(dfArgs, split, pieces, windows) { + n <- length(split$entry) + given <- if (is.null(windows)) { + .placeholderRanges(n) + } else { + windows[split$fromIdx] + } + cbind( + exec(S4Vectors::DataFrame, !!!dfArgs)[split$fromIdx, , drop = FALSE], + exec( + S4Vectors::DataFrame, + !!!.regionColumns( + given, + rep(!is.null(windows), n), + .rowSpanRanges(pieces) + ) + ) + ) +} + +# The window each tuple was given, as bare ranges, one per tuple; NULL when +# none was. A single window stands for every tuple. +# @noRd +.qssWindows <- function(region, n) { + if (is.null(region)) { + return(NULL) + } + windows <- .asRegionRanges(region) + if (!is_in(length(windows), c(1L, n))) { + abort(glue( + "`region` must give one window, or one per tuple ", + "(got {length(windows)} for {n} tuples)." + )) + } + .bareRanges(rep(windows, length.out = n)) +} + +# Each tuple's variants inside its window. Those outside it were not asked +# for, so they are dropped, with a warning saying how many. +# @noRd +.qssWithinWindows <- function(entry, windows) { + if (is.null(windows)) { + return(entry) + } + kept <- map( + seq_along(entry), + .qssWithinWindowAt, + entry = as.list(entry), + windows = windows + ) + dropped <- sum(lengths(entry)) - sum(lengths(kept)) + if (dropped > 0L) { + warn(glue( + "{dropped} variant(s) lie outside their tuple's `region` and ", + "were dropped." + )) + } + kept +} + +# @noRd +.qssWithinWindowAt <- function(i, entry, windows) { + .withinWindow(entry[[i]], windows[i]) +} + +# Narrow the tuples a pipeline selected -- `rows`, picked by its own +# `contexts` / `traitId` rules -- to their traits' cis windows: traitPos +/- +# cisWindow, within the window each tuple already had. That window becomes +# the tuple's `region`, recorded as given, since the caller asked for it. A +# selected tuple with no trait position has no cis window, which is an error. +# NULL `cisWindow` leaves `x` as it is. The one step behind every pipeline +# that takes a QtlSumStats and a `cisWindow`; `caller` names it in messages. +# @noRd +#' @importFrom checkmate assertNumber +.qssApplyCisWindow <- function(x, cisWindow, caller, rows) { + if (is.null(cisWindow)) { + return(x) + } + assertNumber(cisWindow, lower = 0, finite = TRUE, .var.name = "cisWindow") + if (length(rows) == 0L) { + return(x) + } + regions <- .rowRegions(x) + windows <- .clipWindows( + .cisWindowsAround(.qssTraitPositions(x, rows, caller), cisWindow), + regions$region[rows] + ) + elements <- replace( + as.list(x), + rows, + map( + seq_along(rows), + .qssWithinWindowAt, + entry = as.list(x)[rows], + windows = windows + ) + ) + region <- regions$region + region[rows] <- windows + .withRegionColumns( + .rtlRebuild(x, elements, seq_len(nrow(x))), + list( + region = region, + regionGiven = replace(regions$regionGiven, rows, TRUE) + ) + ) +} + +# A QtlSumStats run's selection, parsed once (parseContexts() / +# parseTraitIds()), and its data with `cisWindow` laid on the tuples that +# selection keeps -- so the windows cover exactly the tuples the run fits. +# @noRd +.qssSelection <- function(data, contexts, traitId, cisWindow, caller) { + contexts <- parseContexts(contexts, data) + traitId <- parseTraitIds(traitId, data) + rows <- which(.sumStatsRowsSelected(data, contexts, traitId)) + list( + data = .qssApplyCisWindow(data, cisWindow, caller, rows), + contexts = contexts, + traitId = traitId + ) +} + +# Each trait position widened by `cisWindow` on both sides, kept on the +# chromosome. +# @noRd +.cisWindowsAround <- function(tp, cisWindow) { + w <- as.integer(cisWindow) + GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(tp)), + IRanges::IRanges(start = pmax(1L, start(tp) - w), end = end(tp) + w) + ) +} + +# The trait position of each of `rows`; an error naming the tuples that have +# none, since a cis window is laid around the trait. +# @noRd +.qssTraitPositions <- function(x, rows, caller) { + tp <- if (is_in("traitPos", .tupleColumnNames(x))) { + .tupleColumn(x, "traitPos")[rows] + } + missing <- if (is.null(tp)) { + rows + } else { + rows[as.character(GenomicRanges::seqnames(tp)) == "chrUn"] + } + if (length(missing) > 0L) { + labels <- str_c( + as.character(x$study)[missing], + as.character(x$context)[missing], + as.character(x$trait)[missing], + sep = "/" + ) + abort(c( + glue( + "{caller}: `cisWindow` is laid around each tuple's trait ", + "position, which {length(missing)} tuple(s) do not have: ", + "{str_flatten(utils::head(labels, 5L), ', ')}." + ), + i = str_c( + "Give one with `traitPos` (or a manifest's traitStart / ", + "traitEnd columns), or drop `cisWindow` to analyse each ", + "tuple over its `region`." + ) + )) + } + tp +} + +# Each window clipped to its row's `regions` entry. A window that misses it, +# on another chromosome or past its ends, keeps nothing, so it becomes a +# zero-width placeholder at its start. +# @noRd +.clipWindows <- function(windows, regions) { + same <- as.character(GenomicRanges::seqnames(windows)) == + as.character(GenomicRanges::seqnames(regions)) + s <- pmax(start(windows), start(regions)) + e <- pmin(end(windows), end(regions)) + hit <- same & e >= s + GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(windows)), + IRanges::IRanges( + start = if_else(hit, s, start(windows)), + end = if_else(hit, e, start(windows) - 1L) + ) ) - .sumStatsNewValidated("QtlSumStats", grl, ldReference, genome, qcInfo) } # Validate genome / entry / length consistency and recycle varY. Returns the @@ -201,7 +427,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 reference)." + "collection)." ) abort(msg) } @@ -212,7 +438,7 @@ QtlSumStats <- function( } if (length(context) != n || length(trait) != n || length(entry) != n) { msg <- glue( - "`study`, `context`, `trait`, and `entry` must all have the ", + "`studyName`, `context`, `trait`, and `entry` must all have the ", "same length." ) abort(msg) @@ -278,7 +504,17 @@ QtlSumStats <- function( # Append any user-supplied extra columns (from `...`). # @noRd .qssAppendExtras <- function(cols, extras) { - c(cols, extras) + c(cols, .extraColsList(extras)) +} + +# `extraCols` as a named list of columns: a list as it is, a DataFrame or +# data.frame column by column. +# @noRd +.extraColsList <- function(extras) { + if (methods::is(extras, "DataFrame") || is.data.frame(extras)) { + return(as.list(extras)) + } + extras } # Annotate each entry's variants with tss_distance / tes_distance from the @@ -322,7 +558,7 @@ QtlSumStats <- function( return(seq_len(nrow(x))) } msg <- glue( - "This QtlSumStats has {nrow(x)} entries. Pass `study`, ", + "This QtlSumStats has {nrow(x)} entries. Pass `studyName`, ", "`context`, and `trait` to select one." ) abort(msg) @@ -373,10 +609,8 @@ QtlSumStats <- function( #' \code{"bonferroni_filtered"} / \code{"qvalue"}). When set on a QtlSumStats #' enriched by \code{\link{qtlAssociationPostprocess}}, a logical #' \code{significant} mcol for that method is added to the returned entry (the -#' significance is derived on the fly, not stored). Flat export flattens this -#' full entry GRanges (all mcols) directly; note -#' \code{\link{as.data.frame}} is a fixed GWAS-schema view and does not -#' carry the association columns. +#' significance is derived on the fly, not stored). Take a table of the +#' whole entry, every mcol included, with \code{as.data.frame()}. #' @export setMethod( "sumStats", @@ -386,11 +620,10 @@ setMethod( studyName = NULL, context = NULL, trait = NULL, - annotateSignificance = NULL, - ranges = NULL + annotateSignificance = NULL ) { idx <- .qtlSumStatsSelectRow(x, studyName, context, trait) - stitched <- .ssStitchElements(x, idx, ranges) + stitched <- .ssStitchElements(x, idx) gr <- if (is.null(annotateSignificance)) { stitched } else { @@ -419,46 +652,6 @@ setMethod( # z / nSamples / maf / nSnps are provided once by SumStatsBase (AllClasses.R); # they only delegate to sumStats(). -#' @rdname sumStatsDataFrame -#' @export -setMethod( - "as.data.frame", - "QtlSumStats", - function( - x, - row.names = NULL, - optional = FALSE, - studyName = NULL, - context = NULL, - trait = NULL, - require = character(0), - derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE, - ... - ) { - derive <- arg_match(derive) - gr <- sumStats( - x, - studyName = studyName, - context = context, - trait = trait - ) - .entryToSumstatDf( - gr, - require = require, - derive = derive, - keepChrPrefix = keepChrPrefix, - label = glue( - "QtlSumStats[", - "{if (is.null(studyName)) '' else studyName}/", - "{if (is.null(context)) '' else context}/", - "{if (is.null(trait)) '' else trait}]" - ) - ) - } -) - - #' @rdname varY #' @export setMethod( @@ -489,18 +682,15 @@ setMethod("traitNames", "QtlSumStats", function(x) { # or a scalar NA when no trait position was supplied. #' @rdname traitPosition #' @export -setMethod("traitPosition", "QtlSumStats", function(x, traitId = NULL) { +setMethod("traitPosition", "QtlSumStats", function(x, trait = NULL) { tp <- .getTraitPosColumn(x) - if (!methods::is(tp, "GRanges") || is.null(traitId)) { + if (is.null(trait) || length(tp) == 0L) { return(tp) } - idx <- which(is_in(as.character(x$trait), as.character(traitId))) - if (length(idx) == 0L) { - return(NA) - } + idx <- which(is_in(as.character(x$trait), as.character(trait))) # The trait position is per-TUPLE, but a tuple split across chromosomes # owns several elements and the column is replicated across them, so the - # matches collapse back to the one position. + # matches collapse back to the one position. No match is an empty GRanges. unique(tp[idx]) }) @@ -513,7 +703,7 @@ setMethod("traitPosition", "QtlSumStats", function(x, traitId = NULL) { setMethod("show", "QtlSumStats", function(object) { cat(glue( "QtlSumStats: {nrow(object)} entries, ", - "genome build {GenomeInfoDb::genome(object)}\n", + "genome build {.showGenomeBuild(object)}\n", .trim = FALSE )) if (nrow(object) > 0L) { @@ -524,12 +714,7 @@ setMethod("show", "QtlSumStats", function(object) { .trim = FALSE )) } - ld <- ldReference(object) - ldSrc <- if (is.null(ld)) { - "none (LD-free)" - } else { - .ldRefLabel(ld) - } + ldSrc <- .ldRefsLabel(ldReference(object), "none (LD-free)") cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) @@ -579,16 +764,16 @@ 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 -#' references combine the same way (all-\code{NULL} stays \code{NULL}, which -#' is the usual case for individual-level QTL data). +#' and the \code{\link{summaryStatsQc}} options must agree, each row keeps +#' its own QC audit, and the rows keep their own LD references, stored the +#' same way. #' #' @param ... Two or more \code{QtlSumStats} objects, or a single \code{list} #' of them. -#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) -#' to attach to the combined collection, overriding the unioned one. Default -#' \code{NULL}. +#' @param ldReference Optional LD reference -- a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +#' \code{LdMatrix} -- that every row of the combined collection uses +#' instead of its own. Default \code{NULL}. #' @return A single combined \code{QtlSumStats}. #' @seealso \code{\link{combineGwasSumStats}}, #' \code{\link{combineFineMappingResults}}, \code{\link{combineTwasWeights}} diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 2a3f00f5..1e8817f9 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -340,7 +340,6 @@ prsCsWeights <- function( #' @param iter Number of iterations for MCMC. Default is 1000. #' @param burn Number of burn-in iterations for MCMC. Default is 200. #' @param thin Thinning interval for MCMC. Default is 5. -#' @param numThreads Number of threads to use. Default is 1. #' @param optLlk 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. @@ -371,7 +370,6 @@ sdpr <- function( iter = 1000, burn = 200, thin = 5, - numThreads = 1, optLlk = 1, verbose = TRUE, seed = NULL @@ -391,7 +389,6 @@ sdpr <- function( iter, burn, thin, - numThreads, optLlk, verbose, seed @@ -416,7 +413,6 @@ sdpr <- function( iter, burn, thin, - numThreads, optLlk, verbose, seed @@ -436,7 +432,9 @@ sdpr <- function( iter = as.integer(iter), burn = as.integer(burn), thin = as.integer(thin), - numThreads = as.integer(numThreads), + # The kernel's thread pool splits its work across LD blocks, and a + # window is always one block, so a second thread would sit idle. + numThreads = 1L, optLlk = as.integer(optLlk), verbose = verbose, seed = seed @@ -536,7 +534,6 @@ sdprWeights <- function( "iter", "burn", "thin", - "numThreads", "optLlk", "verbose", "seed" @@ -902,8 +899,10 @@ mrmashRssWeights <- function( #' A method's individual-level and summary-statistic paths often run #' DIFFERENT engines, and then each takes its own constructor: #' \code{lassoWeights} fits with glmnet (\code{GlmnetOptions}) while -#' \code{lassosumRssWeights} runs pecotmr's lassosum solver -#' (\code{LassosumOptions}); \code{scadWeights} / \code{mcpWeights} / +#' \code{lassosumRssWeights} runs pecotmr's lassosum +#' (\code{LassosumOptions}); \code{enetWeights} / \code{ridgeWeights} fit +#' with glmnet too, while \code{enetRssWeights} / \code{ridgeRssWeights} +#' use \code{PenalizedRssOptions}; \code{scadWeights} / \code{mcpWeights} / #' \code{l0learnWeights} use ncvreg and L0Learn while their \code{*Rss} #' counterparts use \code{PenalizedRssOptions}; \code{dprGibbsWeights} uses #' RcppDPR and \code{sdprWeights} uses \code{SdprOptions}. Splitting them is @@ -974,7 +973,10 @@ GlmnetOptions <- function(...) { # lasso from enet from ridge -- so it belongs to the calling # wrapper. Refused here rather than in glmnetWeights() so the # failure lands where the value was written. - alpha = "the calling wrapper (lassoWeights, enetWeights)" + alpha = str_c( + "the calling wrapper: enetWeights' own `alpha`, or ", + "lassoWeights / ridgeWeights, which fix it" + ) ), "GlmnetOptions" ) @@ -1217,12 +1219,31 @@ LassosumOptions <- function(...) { #' @export PenalizedRssOptions <- function(...) { extra <- list(...) + # The penalty and its shape belong to the calling wrapper: each one fixes + # its penalty, and those that let it vary take `alpha` / `gamma` / + # `lambda0` / `lambda2` / `maxSwaps` as their own arguments. `lambda` + # stays settable here, the only route to it for the wrappers without one. .configRefuseOwned( extra, c( bhat = "supplied from the data by the pipeline", R = "supplied from the data by the pipeline", - n = "supplied from the data by the pipeline" + n = "supplied from the data by the pipeline", + penalty = str_c( + "the calling wrapper, which fixes it (scadRssWeights, ", + "mcpRssWeights, ...)" + ), + alpha = str_c( + "the calling wrapper's `alpha` (enetRssWeights, ", + "scadRssWeights, mcpRssWeights); ridgeRssWeights fixes it at 0" + ), + gamma = str_c( + "the calling wrapper's `gamma` (scadRssWeights, ", + "mcpRssWeights)" + ), + lambda0 = "l0learnRssWeights' own `lambda0`", + lambda2 = "l0learnRssWeights' own `lambda2`", + maxSwaps = "l0learnRssWeights' own `maxSwaps`" ), "PenalizedRssOptions" ) @@ -1270,7 +1291,7 @@ MrmashOptions <- function(...) { mu1_init = "the wrapper's `bInit`", standardize = "the wrapper's `standardize`", update_V_method = "the wrapper's `updateVMethod`", - nthreads = "the wrapper's `numThreads`" + nthreads = "the wrapper's `BPPARAM`" ), "MrmashOptions" ) @@ -1443,9 +1464,12 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { replace(eff.wgt, keep, coef(enet, s = "lambda.min")[2:(sum(keep) + 1)]) } -#' Compute TWAS weights via elastic net (glmnet, alpha = 0.5) +#' Compute TWAS weights via elastic net (glmnet) #' -#' Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0.5}. +#' Convenience wrapper for \code{\link{glmnetWeights}} at a mixing between the +#' lasso and ridge, \code{alpha = 0.5} unless set. +#' @param alpha Elastic-net mixing in \code{[0, 1]}: the L1 share of the +#' penalty. Default 0.5. #' @inheritParams glmnetWeights #' @return Numeric vector of length \code{ncol(X)} of per-variant weights. #' @examples @@ -1453,10 +1477,30 @@ glmnetWeights <- function(X, y, alpha, methodArgs = GlmnetOptions()) { #' X <- eqtlRegionExample$X[, 1:30] #' y <- eqtlRegionExample$yRes #' enetWeights(X, y) +#' # A larger ridge share: +#' enetWeights(X, y, alpha = 0.2) +#' @importFrom checkmate assertNumber +#' @export +enetWeights <- function(X, y, alpha = 0.5, methodArgs = GlmnetOptions()) { + .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") + assertNumber(alpha, lower = 0, upper = 1) + glmnetWeights(X, y, alpha, methodArgs = methodArgs) +} + +#' Compute TWAS weights via ridge regression (glmnet, alpha = 0) +#' +#' Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0}. +#' @inheritParams glmnetWeights +#' @return Numeric vector of length \code{ncol(X)} of per-variant weights. +#' @examples +#' data(eqtlRegionExample) +#' X <- eqtlRegionExample$X[, 1:30] +#' y <- eqtlRegionExample$yRes +#' ridgeWeights(X, y) #' @export -enetWeights <- function(X, y, methodArgs = GlmnetOptions()) { +ridgeWeights <- function(X, y, methodArgs = GlmnetOptions()) { .assertMethodOptions(methodArgs, "GlmnetOptions", "methodArgs") - glmnetWeights(X, y, 0.5, methodArgs = methodArgs) + glmnetWeights(X, y, 0, methodArgs = methodArgs) } #' Compute TWAS weights via lasso (glmnet, alpha = 1) @@ -2278,7 +2322,10 @@ bayesRWeights <- function( #' \hat\beta / \sqrt{n}}. #' #' Based on Mak et al (2017) "Polygenic scores via penalized regression on -#' summary statistics", Genetic Epidemiology 41(6):469-480. +#' summary statistics", Genetic Epidemiology 41(6):469-480. It runs on the +#' solver of \code{\link{penalizedRss}}, whose LASSO at \code{alpha = 1} is +#' lassosum's coordinate descent: the same updates in the same order, so the +#' same coefficients bit for bit. #' #' Internal: \code{\link{lassosumRssWeights}} is the public interface. It #' runs this over a grid of LD shrinkage values, forwards \code{lambda}, @@ -2291,7 +2338,7 @@ bayesRWeights <- function( #' window), as in \code{susieR::susie_rss()}. If shrinkage is desired, apply #' it before passing (e.g., \code{(1-s)*R + s*I}). #' @param n Sample size of the GWAS. -#' @param lambda A vector of L1 penalty values. Default: 20 values from 0.001 to +#' @param lambda A vector of L1 penalty values. Default: 20 values from 1e-4 to #' 0.1 on log scale. #' @param thr Convergence threshold. Default: 1e-4. #' @param maxiter Maximum number of iterations. Default: 10000. @@ -2315,35 +2362,15 @@ 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) - .rssSolvePath( + .penalizedRssPath( bhat, - ld, + list(R = R), n, - lambda, - .rssLassosumSolve, - solveArgs = list(thr = thr, maxiter = maxiter) - ) -} - -# .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 + spec = .rssPenalty("lasso"), + lambda = lambda, + thr = thr, + maxiter = maxiter ) - exec(.lassosumRssPath, bhat = bhat, ld = ld, n = n, !!!settings) } # The values `fn` declares as the defaults of its formals `fmlNames`, @@ -2486,17 +2513,15 @@ lassosumRss <- function( ) } -# Per-`s` fit for one RSS method (`method` selects the solver + which `config` -# fields apply). Returns list(beta, meta); l0learn's inner lambda0 sweep is -# here. +# Per-`s` fit for one RSS method: one penalized path at the wrapper's +# penalty, or, for l0learn, one per value of its lambda0 grid. Returns +# list(beta, meta). # @noRd -.rssFitOne <- function(method, solverInput, ld, n, sVal, config) { - switch( - method, - lassosum = .rssFitLassosum(solverInput, ld, n, sVal, config), - penalized = .rssFitPenalized(solverInput, ld, n, sVal, config), - l0learn = .rssFitL0learn(solverInput, ld, n, sVal, config) - ) +.rssFitOne <- function(solverInput, ld, n, sVal, config) { + if (identical(config$method, "l0learn")) { + return(.rssFitL0learn(solverInput, ld, n, sVal, config)) + } + .rssFitPenalized(solverInput, ld, n, sVal, config) } # Shared per-candidate frame for a single-path model: the shrinkage s and @@ -2514,27 +2539,17 @@ lassosumRss <- function( ) } -# lassosum shrinkage path for one s, against `ld` shrunk to that s. -# @noRd -.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, against `ld` shrunk to that s. +# The penalized path for one s, against `ld` shrunk to that s: the wrapper's +# penalty, `config$spec`, under the caller's path options. # @noRd .rssFitPenalized <- function(solverInput, ld, n, sVal, config) { - settings <- c( - list( - penalty = config$penalty, - gamma = config$gamma, - alpha = config$alpha, - lambda0 = config$lambda0, - lambda2 = config$lambda2 - ), - as.list(config$dotArgs) + model <- .penalizedRssOn( + solverInput, + ld, + n, + config$spec, + config$options ) - model <- .penalizedRssOn(solverInput, ld, n, settings) list(beta = model$beta, meta = .rssPathMeta(sVal, model)) } @@ -2561,10 +2576,10 @@ lassosumRss <- function( # Attach the method-specific selection attribute to the chosen coefficient # vector. # @noRd -.rssFinalize <- function(method, bestBeta, sel, meta, config) { +.rssFinalize <- function(bestBeta, sel, meta, config) { base <- c(mode = sel$mode, index = sel$index) selection <- switch( - method, + config$method, lassosum = c( base, s = meta$s[sel$index], @@ -2572,19 +2587,20 @@ lassosumRss <- function( ), penalized = c( base, - penalty = config$penalty, + penalty = config$spec$penalty, + alpha = config$spec$alpha, s = meta$s[sel$index], lambda = meta$lambda[sel$index] ), l0learn = c( base, - penalty = config$penalty, + penalty = config$spec$penalty, s = meta$s[sel$index], lambda0 = meta$lambda0[sel$index], lambda = meta$lambda[sel$index] ) ) - attrName <- if (method == "lassosum") { + attrName <- if (config$method == "lassosum") { "lassosum_selection" } else { "penalized_rss_selection" @@ -2644,8 +2660,8 @@ lassosumRss <- function( # 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) +.rssFitAtS <- function(sVal, solverInput, ld, n, config) { + .rssFitOne(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 @@ -2661,14 +2677,15 @@ lassosumRss <- function( # 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. +# selection. `config` is the run: `method` (which selection record the +# weights carry; "l0learn" also sweeps `lambda0`), the penalty `spec` +# (.rssPenalty()) and the caller's path `options`; `fitRetention` is how much +# of the search is kept. # @noRd .rssShrinkGridWeights <- function( stat, ld, s, - method, config, selection = c("ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full") @@ -2682,7 +2699,6 @@ lassosumRss <- function( fits <- map( s, .rssFitAtS, - method = method, solverInput = solverInput, ld = ld, n = n, @@ -2696,13 +2712,7 @@ lassosumRss <- function( .lassosumSelectMinFbeta(candidateBeta, candidateMeta) } bestBeta <- as.numeric(selectorResult$beta) - weights <- .rssFinalize( - method, - bestBeta, - selectorResult, - candidateMeta, - config - ) + weights <- .rssFinalize(bestBeta, selectorResult, candidateMeta, config) .rssAttachGridFit( weights, candidateBeta, @@ -2815,8 +2825,11 @@ lassosumRssWeights <- function( stat, .rssLdSource(stat, ldReference, "lassosumRssWeights"), s, - "lassosum", - list(dotArgs = methodArgs), + list( + method = "lassosum", + spec = .rssPenalty("lasso"), + options = as.list(methodArgs) + ), selection, fitRetention ) @@ -2824,13 +2837,15 @@ lassosumRssWeights <- function( #' Penalized Regression on RSS (Summary Statistics) Objective #' -#' Generalizes \code{lassosumRss()} to support LASSO, MCP, SCAD, L0, L0L1, -#' and L0L2 penalties. Uses coordinate descent on the objective +#' The RSS penalized-regression solver: LASSO with its elastic-net and ridge +#' mixtures, MCP, SCAD, L0, L0L1 and L0L2. Uses coordinate descent on the +#' objective #' \deqn{\beta^T R \beta - 2 \beta^T z + \mathrm{penalty}(\beta)} #' where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / -#' \sqrt{n}}. +#' \sqrt{n}}. \code{lassosumRss()} is its LASSO at \code{alpha = 1}. #' -#' Internal: \code{\link{scadRssWeights}}, \code{\link{mcpRssWeights}} and +#' Internal: \code{\link{enetRssWeights}}, \code{\link{ridgeRssWeights}}, +#' \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 @@ -2846,11 +2861,17 @@ lassosumRssWeights <- function( #' @param lambda Numeric vector of regularization parameter values along which #' to trace a solution path (warm-started, largest-first). For LASSO/MCP/SCAD #' this is the primary penalty strength; for L0 variants it controls the L1 -#' component. +#' component. \code{NULL} (default) is 20 values from 1e-4 to 0.1 on a log +#' scale, divided by \code{max(alpha, 0.001)} as glmnet sizes its path, so +#' the L1 share spans the same range at any \code{alpha} and a ridge path +#' runs from 0.1 to 100. #' @param gamma Concavity parameter for MCP (default 3) or SCAD (default 3.7). #' Ignored for LASSO and L0 variants. -#' @param alpha Elastic-net mixing for MCP/SCAD: \eqn{l_1 = \lambda \alpha}, -#' \eqn{l_2 = \lambda (1-\alpha)}. Default 1 (pure L1, no ridge). +#' @param alpha Elastic-net mixing for LASSO, MCP and SCAD, in \code{[0, 1]}: +#' \eqn{l_1 = \lambda \alpha} and \eqn{l_2 = \lambda (1-\alpha)}, so the +#' penalty is \eqn{2 P(\beta; l_1) + l_2 \beta^T \beta}, glmnet's mixing. +#' Default 1, no ridge term. For LASSO, 0.5 is the elastic net and 0 ridge; +#' MCP and SCAD need \code{alpha > 0}. Ignored by the L0 variants. #' @param lambda0 L0 penalty weight (number of non-zeros). Required for L0 #' variants; ignored otherwise. Default 0. #' @param lambda2 L2 penalty weight for L0L2 variant. Default 0. @@ -2877,7 +2898,7 @@ penalizedRss <- function( R, n, penalty = c("lasso", "MCP", "SCAD", "L0", "L0L1", "L0L2"), - lambda = exp(seq(log(0.0001), log(0.1), length.out = 20)), + lambda = NULL, gamma = NULL, alpha = 1.0, lambda0 = 0, @@ -2890,129 +2911,157 @@ penalizedRss <- function( bhat, list(R = R), n, - arg_match(penalty), - lambda, - gamma, - alpha, - lambda0, - lambda2, - thr, - maxiter, - maxSwaps + spec = .rssPenalty( + arg_match(penalty), + alpha = alpha, + gamma = gamma, + lambda0 = lambda0, + lambda2 = lambda2, + maxSwaps = maxSwaps + ), + lambda = lambda, + thr = thr, + maxiter = maxiter ) } -# penalizedRss() on an LD source: the matrix, or a factor of it with its -# shrinkage, which the factor solver applies without forming R. +# The penalty a fit minimizes, as one checked record: the solver's penalty +# name, the elastic-net mixing `alpha`, the MCP / SCAD concavity `gamma` +# (their usual default when NULL) and the L0 settings. Each weight wrapper +# builds it from its own arguments before its shrinkage grid starts, so the +# penalty is the wrapper's alone and only the path (lambda, thr, maxiter) is +# left to the caller's options. # @noRd -.penalizedRssPath <- function( - bhat, - ld, - n, +#' @importFrom checkmate assertCount assertNumber +.rssPenalty <- function( penalty, - lambda, - gamma, - alpha, - lambda0, - lambda2, - thr, - maxiter, - maxSwaps + alpha = 1, + gamma = NULL, + lambda0 = 0, + lambda2 = 0, + maxSwaps = 0 ) { - # Default gamma per penalty - gamma <- gamma %||% switch(penalty, SCAD = 3.7, MCP = 3.0, 0.0) + .rssCheckAlpha(penalty, alpha) + assertNumber(gamma, finite = TRUE, null.ok = TRUE) + assertNumber(lambda0, lower = 0, finite = TRUE) + assertNumber(lambda2, lower = 0, finite = TRUE) + assertCount(maxSwaps) + list( + penalty = penalty, + alpha = alpha, + gamma = gamma %||% switch(penalty, SCAD = 3.7, MCP = 3.0, 0.0), + lambda0 = lambda0, + lambda2 = lambda2, + maxSwaps = maxSwaps + ) +} + +# `alpha` for `penalty`: a share in [0, 1], and above 0 for MCP and SCAD, +# where 0 leaves only the ridge term, which ridgeRssWeights() fits. +# @noRd +.rssCheckAlpha <- function(penalty, alpha) { + assertNumber(alpha, lower = 0, upper = 1) + if (alpha == 0 && is_in(penalty, c("MCP", "SCAD"))) { + abort(glue( + "`alpha` must be above 0 for {penalty}: at 0 only the ridge term ", + "is left, which ridgeRssWeights() fits." + )) + } + invisible(NULL) +} + +# penalizedRss() on an LD source: the matrix, or a factor of it with its +# shrinkage, which the factor solver applies without forming R. `spec` is the +# penalty (.rssPenalty()); the rest is the path, its default sized by the L1 +# share. +# @noRd +.penalizedRssPath <- function(bhat, ld, n, spec, lambda, thr, maxiter) { + lambda <- lambda %||% .rssDefaultLambda(spec$alpha) + assertNumeric(lambda, lower = 0, any.missing = FALSE) + assertNumber(thr, lower = 0, finite = TRUE) + assertCount(maxiter, positive = TRUE) .rssSolvePath( bhat, ld, n, lambda, .rssPenalizedSolve, - solveArgs = list( - penalty = penalty, - gamma = gamma, - alpha = alpha, - lambda0 = lambda0, - lambda2 = lambda2, - thr = thr, - maxiter = maxiter, - maxSwaps = maxSwaps - ) + solveArgs = c(spec, list(thr = thr, maxiter = maxiter)) ) } -# .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. +# The default lambda path: 20 values from 1e-4 to 0.1, sized for an L1 +# penalty on correlation-scale effects, divided by max(alpha, 0.001) as glmnet +# sizes its own. The L1 share then spans the same range at any alpha, and a +# ridge path (alpha = 0) runs from 0.1 to 100; at alpha = 1 it is the +# lassosum default unchanged. # @noRd -.penalizedRssOn <- function(bhat, ld, n, args) { - settings <- list_modify( - .formalDefaults( - penalizedRss, - c( - "lambda", - "gamma", - "alpha", - "lambda0", - "lambda2", - "thr", - "maxiter", - "maxSwaps" - ) - ), - !!!args +.rssDefaultLambda <- function(alpha) { + exp(seq(log(1e-4), log(0.1), length.out = 20L)) / max(alpha, 1e-3) +} + +# .penalizedRssPath() for the penalty `spec` under the caller's path +# `options` -- lambda, thr and maxiter, all an options bag may hold -- +# penalizedRss()'s own defaults filling the rest. A matrix takes exactly the +# path penalizedRss() does. +# @noRd +.penalizedRssOn <- function(bhat, ld, n, spec, options) { + path <- list_modify( + .formalDefaults(penalizedRss, c("lambda", "thr", "maxiter")), + !!!options + ) + exec( + .penalizedRssPath, + bhat = bhat, + ld = ld, + n = n, + spec = spec, + !!!path ) - exec(.penalizedRssPath, bhat = bhat, ld = ld, n = n, !!!settings) } #' RSS Weights Helper for Penalized Methods #' -#' Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. +#' Shared implementation for \code{scadRssWeights()}, \code{mcpRssWeights()}, +#' \code{enetRssWeights()} and \code{ridgeRssWeights()}. #' (\code{l0learnRssWeights()} uses the lower-level \code{.rssShrinkGridWeights} #' scaffold directly, since it sweeps an additional \code{lambda0} path.) #' Searches over a shrinkage grid \code{s} (LD matrix shrinkage \code{(1-s)R + #' sI}) and selects the best candidate via LD-quadratic pseudovalidation or #' minimum penalized objective. #' -#' @param stat,ldReference,s,selection,penalty,gamma,alpha,lambda0,lambda2 See -#' the public wrappers for details. +#' @param stat,ldReference,s,selection See the public wrappers for details. +#' @param spec The penalty, built by the calling wrapper from its own +#' arguments (internal \code{.rssPenalty()}). #' @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}}. +#' \code{\link{PenalizedRssOptions}}: the path only, since the penalty is +#' the wrapper's. +#' @param label The calling wrapper's name, for its error messages. #' @return Numeric weight vector, one weight per variant of \code{stat}. #' @keywords internal .penalizedRssWeights <- function( stat, ldReference, - penalty, + spec, s = c(0.2, 0.5, 0.9, 1.0), - gamma = NULL, - alpha = 1.0, - lambda0 = 0, - lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), - methodArgs = PenalizedRssOptions() + methodArgs = PenalizedRssOptions(), + label = str_c(str_to_lower(spec$penalty), "RssWeights") ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") selection <- arg_match(selection) fitRetention <- arg_match(fitRetention) .rssShrinkGridWeights( stat, - .rssLdSource( - stat, - ldReference, - str_c(str_to_lower(penalty), "RssWeights") - ), + .rssLdSource(stat, ldReference, label), s, - "penalized", list( - penalty = penalty, - gamma = gamma, - alpha = alpha, - lambda0 = lambda0, - lambda2 = lambda2, - dotArgs = methodArgs + method = "penalized", + spec = spec, + options = as.list(methodArgs) ), selection, fitRetention @@ -3038,7 +3087,9 @@ penalizedRss <- function( #' @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 alpha Elastic-net mixing in \code{(0, 1]}: the SCAD share of +#' the penalty, the rest a ridge term, as \code{\link{penalizedRss}} +#' mixes them. Default 1, no ridge term. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. #' @param methodArgs Options forwarded to the solver, @@ -3079,15 +3130,13 @@ scadRssWeights <- function( fitRetention <- arg_match(fitRetention) assertList(stat) assertNumeric(s, lower = 0, any.missing = FALSE) - assertNumber(gamma, finite = TRUE) - assertNumber(alpha, finite = TRUE) + # Built before the grid starts, so a bad penalty fails here. + spec <- .rssPenalty("SCAD", alpha = alpha, gamma = gamma) .penalizedRssWeights( stat = stat, ldReference = ldReference, - penalty = "SCAD", + spec = spec, s = s, - gamma = gamma, - alpha = alpha, selection = selection, fitRetention = fitRetention, methodArgs = methodArgs @@ -3113,7 +3162,9 @@ scadRssWeights <- function( #' @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 alpha Elastic-net mixing in \code{(0, 1]}: the MCP share of +#' the penalty, the rest a ridge term, as \code{\link{penalizedRss}} +#' mixes them. Default 1, no ridge term. #' @param selection Selection strategy: \code{"ldQuadratic"} (default) or #' \code{"minFbeta"}. #' @param methodArgs Options forwarded to the solver, @@ -3154,21 +3205,142 @@ mcpRssWeights <- function( fitRetention <- arg_match(fitRetention) assertList(stat) assertNumeric(s, lower = 0, any.missing = FALSE) - assertNumber(gamma, finite = TRUE) - assertNumber(alpha, finite = TRUE) + # Built before the grid starts, so a bad penalty fails here. + spec <- .rssPenalty("MCP", alpha = alpha, gamma = gamma) .penalizedRssWeights( stat = stat, ldReference = ldReference, - penalty = "MCP", + spec = spec, s = s, - gamma = gamma, - alpha = alpha, selection = selection, fitRetention = fitRetention, methodArgs = methodArgs ) } +#' Compute Elastic-Net Weights from Summary Statistics +#' +#' Fits the elastic net on the RSS objective -- the lasso penalty mixed with +#' a ridge term, as glmnet mixes them -- searching over a shrinkage grid +#' \code{s} and a lambda path. Model selection uses LD-quadratic +#' pseudovalidation by default. +#' +#' \code{alpha} is the L1 share of the penalty: with \eqn{l_1 = \lambda +#' \alpha} and \eqn{l_2 = \lambda (1 - \alpha)} the penalty is +#' \eqn{2 l_1 \|\beta\|_1 + l_2 \beta^T \beta}, so \code{alpha = 1} is the +#' lasso and \code{alpha = 0} ridge (\code{\link{ridgeRssWeights}}). The +#' default lambda path is divided by \code{max(alpha, 0.001)}, as glmnet +#' sizes its own, so the L1 share spans the same range at any \code{alpha}. +#' +#' The LD shrinkage adds a ridge term of its own, since +#' \eqn{\beta^T R_s \beta = (1 - s) \beta^T R \beta + s \beta^T \beta}: every +#' RSS lasso is already partly a ridge, and \code{alpha} adds a second ridge +#' term that grows with \eqn{\lambda}. Expect the lasso and the elastic net +#' to differ less on summary statistics than glmnet's do on genotypes. +#' +#' @param alpha Elastic-net mixing in \code{[0, 1]}: the L1 share of the +#' penalty. Default 0.5. +#' @inheritParams scadRssWeights +#' @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] +#' y <- eqtlRegionExample$yRes +#' 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)), +#' variantNames = colnames(X) +#' ) +#' enetRssWeights(stat, LdMatrix(cor(X))) +#' # A larger ridge share: +#' enetRssWeights(stat, LdMatrix(cor(X)), alpha = 0.2) +#' @importFrom checkmate assertList assertNumeric +#' @export +enetRssWeights <- function( + stat, + ldReference, + alpha = 0.5, + s = c(0.2, 0.5, 0.9, 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) + # Built before the grid starts, so a bad mixing fails here. + spec <- .rssPenalty("lasso", alpha = alpha) + .penalizedRssWeights( + stat = stat, + ldReference = ldReference, + spec = spec, + s = s, + selection = selection, + fitRetention = fitRetention, + methodArgs = methodArgs, + label = "enetRssWeights" + ) +} + +#' Compute Ridge Weights from Summary Statistics +#' +#' Fits ridge regression on the RSS objective, \code{\link{enetRssWeights}} +#' at \code{alpha = 0}: the penalty is \eqn{\lambda \beta^T \beta}, and the +#' default lambda path runs from 0.1 to 100. Searches over a shrinkage grid +#' \code{s} as well, whose own ridge term \eqn{s \beta^T \beta} adds to it; +#' model selection uses LD-quadratic pseudovalidation by default. +#' +#' @inheritParams scadRssWeights +#' @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] +#' y <- eqtlRegionExample$yRes +#' 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)), +#' variantNames = colnames(X) +#' ) +#' ridgeRssWeights(stat, LdMatrix(cor(X))) +#' @importFrom checkmate assertList assertNumeric +#' @export +ridgeRssWeights <- function( + stat, + ldReference, + s = c(0.2, 0.5, 0.9, 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) + .penalizedRssWeights( + stat = stat, + ldReference = ldReference, + spec = .rssPenalty("lasso", alpha = 0), + s = s, + selection = selection, + fitRetention = fitRetention, + methodArgs = methodArgs, + label = "ridgeRssWeights" + ) +} + #' Compute L0-Penalized Weights from Summary Statistics #' #' Fits L0-penalized regression (with optional L1/L2 components) on the RSS @@ -3245,9 +3417,18 @@ l0learnRssWeights <- function( methodArgs = PenalizedRssOptions() ) { .assertMethodOptions(methodArgs, "PenalizedRssOptions", "methodArgs") + # Its own `lambda` is the path; one in the options would replace it. + .configRefuseOwned( + methodArgs, + c(lambda = "l0learnRssWeights' own `lambda`"), + "l0learnRssWeights" + ) penalty <- arg_match(penalty) selection <- arg_match(selection) fitRetention <- arg_match(fitRetention) + # The L0 penalty, lambda0 left to the sweep over its grid. + spec <- .rssPenalty(penalty, lambda2 = lambda2, maxSwaps = maxSwaps) + assertNumeric(lambda0, lower = 0, finite = TRUE, any.missing = FALSE) # Default lambda (L1 component) depends on variant if (is.null(lambda)) { @@ -3262,14 +3443,11 @@ l0learnRssWeights <- function( stat, .rssLdSource(stat, ldReference, "l0learnRssWeights"), s, - "l0learn", list( - penalty = penalty, - lambda = lambda, + method = "l0learn", + spec = spec, lambda0 = lambda0, - lambda2 = lambda2, - maxSwaps = maxSwaps, - dotArgs = methodArgs + options = list_assign(as.list(methodArgs), lambda = lambda) ), selection, fitRetention @@ -3771,14 +3949,14 @@ dprAdaptiveGibbsWeights <- function( # Starting coefficients as a plain matrix: .mrmashInitCoefficients() # returns the fit it used, and only its Bhat is wanted here. # @noRd -.mrmashInitB <- function(X, Y, bInitMethod, standardize, numThreads) { +.mrmashInitB <- function(X, Y, bInitMethod, standardize, BPPARAM) { as.matrix( .mrmashInitCoefficients( X, Y, bInitMethod, standardize, - numThreads + BPPARAM )$Bhat ) } @@ -3797,7 +3975,7 @@ dprAdaptiveGibbsWeights <- function( bInitMethod, sumstats, standardize, - numThreads + threads ) { .mrmashRequirePackages() .assertMethodParam(prior, "MrmashPriorParam") @@ -3810,7 +3988,7 @@ dprAdaptiveGibbsWeights <- function( canonicalPriorMatrices = priorOpts$canonicalPriorMatrices %||% FALSE ) if (is.null(sumstats)) { - sumstats <- .mrmashComputeSumstats(X, Y, standardize, numThreads) + sumstats <- .mrmashComputeSumstats(X, Y, standardize, threads) } list( bInitMethod = .mrmashResolveBInit(Y, bInitMethod), @@ -3850,8 +4028,12 @@ dprAdaptiveGibbsWeights <- function( #' data. Default is FALSE. Used by the summary-statistic and initialisation #' steps as well as the fit, so it is set here rather than in #' \code{methodArgs}. -#' @param numThreads The number of threads to use for parallel computation. -#' Default is 1. Used by the same three steps as \code{standardize}. +#' @param BPPARAM A \code{BiocParallelParam}. The univariate glmnet fits that +#' initialise the coefficients run on its workers, and mr.mash's own +#' threads (the summary statistics and the fit) number its workers when +#' they run on this machine (\code{SerialParam}, \code{MulticoreParam}); +#' for other backends mr.mash runs on one thread. Default +#' \code{SerialParam()}. #' @param methodArgs Options forwarded to \code{mr.mashr::mr.mash} under its #' own names, built with \code{\link{MrmashOptions}} #' (\code{update_w0}, \code{max_iter}, \code{tol}, \code{w0_threshold}, @@ -3912,9 +4094,11 @@ mrmashWrapper <- function( updateV = TRUE, updateVMethod = "full", standardize = FALSE, - numThreads = 1, + BPPARAM = SerialParam(), methodArgs = MrmashOptions() ) { + .assertBpparam(BPPARAM) + threads <- .bpLocalThreads(BPPARAM, "mrmashWrapper") setup <- .mrmashWrapperSetup( X = X, Y = Y, @@ -3924,12 +4108,12 @@ mrmashWrapper <- function( bInitMethod = bInitMethod, sumstats = sumstats, standardize = standardize, - numThreads = numThreads + threads = threads ) bInitMethod <- setup$bInitMethod priorBuilt <- setup$priorBuilt time1 <- proc.time() - bInit <- .mrmashInitB(X, Y, bInitMethod, standardize, numThreads) + bInit <- .mrmashInitB(X, Y, bInitMethod, standardize, BPPARAM) vInit <- .mrmashInitV(X, Y, V, updateV, updateVMethod) fitMrmash <- .mrmashFit( priorBuilt$S0, @@ -3938,7 +4122,7 @@ mrmashWrapper <- function( X = X, Y = Y, standardize = standardize, - numThreads = numThreads, + threads = threads, updateVMethod = updateVMethod, methodArgs = methodArgs ) @@ -4003,13 +4187,13 @@ mrmashWrapper <- function( # Univariate summary statistics (Bhat/Shat) for the prior + init. # @noRd -.mrmashComputeSumstats <- function(X, Y, standardize, numThreads) { +.mrmashComputeSumstats <- function(X, Y, standardize, threads) { mr.mashr::compute_univariate_sumstats( X, Y, standardize = standardize, standardize.response = FALSE, - mc.cores = numThreads + mc.cores = threads ) } @@ -4020,14 +4204,13 @@ mrmashWrapper <- function( Y, bInitMethod, standardize, - numThreads + BPPARAM ) { if (bInitMethod == "glasso") { return(computeCoefficientsGlasso( X, Y, standardize = standardize, - numThreads = numThreads, Xnew = NULL )) } @@ -4036,7 +4219,7 @@ mrmashWrapper <- function( Y, alpha = 0.5, standardize = standardize, - numThreads = numThreads, + BPPARAM = BPPARAM, Xnew = NULL ) } @@ -4093,7 +4276,7 @@ mrmashWrapper <- function( X, Y, standardize, - numThreads, + threads, updateVMethod, methodArgs ) { @@ -4107,7 +4290,7 @@ mrmashWrapper <- function( update_V_method = updateVMethod, mu1_init = bInit, standardize = standardize, - nthreads = numThreads + nthreads = threads ) user <- as.list(methodArgs) clash <- intersect(names(user), names(derived)) @@ -4146,7 +4329,6 @@ mrmashWrapper <- function( #' @param Y Numeric response matrix (samples x conditions). #' @param standardize Logical; standardize the columns of \code{X} before #' fitting. -#' @param numThreads Integer; number of threads for the group-lasso fit. #' @param Xnew Optional new design matrix for prediction; \code{NULL} returns #' in-sample coefficients. #' @return A numeric matrix of initial coefficient estimates (variants x @@ -4155,19 +4337,11 @@ mrmashWrapper <- function( #' data(eqtlRegionExample) #' X <- eqtlRegionExample$X[, 1:30] #' Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) -#' computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, -#' numThreads = 1L, Xnew = NULL) -#' @importFrom checkmate assertFlag assertInt +#' computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, Xnew = NULL) +#' @importFrom checkmate assertFlag #' @export -computeCoefficientsGlasso <- function( - X, - Y, - standardize, - numThreads, - Xnew = NULL -) { +computeCoefficientsGlasso <- function(X, Y, standardize, Xnew = NULL) { assertFlag(standardize) - assertInt(numThreads) p <- ncol(X) r <- ncol(Y) conditionNames <- colnames(Y) @@ -4239,33 +4413,28 @@ computeCoefficientsGlasso <- function( } # 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. +# independent, so they run on BPPARAM's workers, each on its own seeded +# random-number stream (cv.glmnet draws its folds at random). The data go by +# position: a named `X` would be taken for bplapply()'s own X. # @noRd computeCoefficientsUnivGlmnet <- function( X, Y, alpha, standardize, - numThreads = 1L, + BPPARAM = SerialParam(), Xnew = NULL ) { - r <- ncol(Y) - 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) - } + out <- .bpMap( + seq_len(ncol(Y)), + .linreg, + X, + Y, + alpha, + standardize, + Xnew, + BPPARAM = BPPARAM + ) bhatList <- map(out, "bhat") Bhat <- exec(cbind, !!!bhatList) @@ -4628,32 +4797,9 @@ buildMrmashPriorMatrices <- function( # ---- map/apply helpers (lambda-free callbacks) --------------------------- -# `.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, 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 = ld$R), - shrink = ld$shrink %||% 0, - lambdaR = lam, - thr = thr, - maxiter = as.integer(maxiter) - ) -} - -# `.rssSolvePath` solver for the penalized (MCP/SCAD/L0...) RSS path, on the -# LD matrix or on a factor of it (never forming R). +# `.rssSolvePath` solver for the penalized RSS path (lasso and its elastic-net +# and ridge mixtures, MCP, SCAD, L0...), on the LD matrix or on a factor of it +# (never forming R). # @noRd .rssPenalizedSolve <- function( z, @@ -4700,17 +4846,13 @@ buildMrmashPriorMatrices <- function( # One L0Learn fit at lambda0 = `l0Val`: penalizedRss over the lambda path. # @noRd .rssL0LambdaFit <- function(l0Val, solverInput, ld, n, sVal, config) { - settings <- c( - list( - penalty = config$penalty, - lambda = config$lambda, - lambda0 = l0Val, - lambda2 = config$lambda2, - maxSwaps = config$maxSwaps - ), - as.list(config$dotArgs) + model <- .penalizedRssOn( + solverInput, + ld, + n, + list_assign(config$spec, lambda0 = l0Val), + config$options ) - model <- .penalizedRssOn(solverInput, ld, n, settings) list( beta = model$beta, meta = mutate(.rssPathMeta(sVal, model), lambda0 = l0Val, .after = "s") diff --git a/R/relatednessQc.R b/R/relatednessQc.R index 54e690ee..38d1b2ee 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -174,7 +174,8 @@ PlinkQcOptions <- function( analysisType, phenoData, phenoCol, - columns + columns, + relatednessThreshold ) .relatednessIterativeCleanup( filtered$kin, @@ -275,7 +276,8 @@ filterRelatedness <- function( analysisType, phenoData, phenoCol, - columns + columns, + relatednessThreshold ) { if (analysisType == "maximizeUnrelated") { return(list( @@ -283,7 +285,14 @@ filterRelatedness <- function( kin = kin )) } - .relatednessMaximizeCases(kin, pqArgs, phenoData, phenoCol, columns) + .relatednessMaximizeCases( + kin, + pqArgs, + phenoData, + phenoCol, + columns, + relatednessThreshold + ) } # @noRd @@ -459,7 +468,8 @@ filterRelatedness <- function( pqArgs, phenoData, phenoCol, - columns + columns, + relatednessThreshold ) { iid1Col <- columns$iid1 iid2Col <- columns$iid2 @@ -483,7 +493,8 @@ filterRelatedness <- function( kin, casesKeep, relatedControls, - columns + columns, + relatednessThreshold ) # Step 3: filter among the remaining controls. controlsKeep <- setdiff(relatedControls, controlsExclude) @@ -497,15 +508,21 @@ filterRelatedness <- function( # Controls related to a retained case (row order preserved; a case--control # edge excludes the control, mirroring the original per-row if / else-if). +# Related means above `relatednessThreshold`, the test plinkQC applies to the +# case and control steps on either side of this one. The xqtl-protocol +# GWAS_QC.R this was ported from took every listed pair, so a control whose +# kinship with a kept case fell below the threshold was dropped too. # @noRd .relatednessControlsToExclude <- function( kin, casesKeep, relatedControls, - columns + columns, + relatednessThreshold ) { - iid1 <- kin[[columns$iid1]] - iid2 <- kin[[columns$iid2]] + related <- filter(kin, .data[[columns$value]] > relatednessThreshold) + iid1 <- related[[columns$iid1]] + iid2 <- related[[columns$iid2]] mask1 <- is_in(iid1, casesKeep) & is_in(iid2, relatedControls) mask2 <- is_in(iid2, casesKeep) & is_in(iid1, relatedControls) contrib <- case_when( diff --git a/R/resultReaders.R b/R/resultReaders.R index 5b9a3f87..e0bc54af 100644 --- a/R/resultReaders.R +++ b/R/resultReaders.R @@ -2,7 +2,7 @@ # Published result readers # ----------------------------------------------------------------------------- # The inverse of R/resultWriters.R: take a file that was published -- by -# `exportToBed()` / `exportToVcf()`, or by another tool writing the same +# `writeBed()` / `writeGwasVcf()`, or by another tool writing the same # vocabulary -- and rebuild the S4 collection. # # readFineMappingResult(path, ...) -> Qtl / GwasFineMappingResult @@ -85,7 +85,8 @@ NULL weight_standardized = "standardized", joint_studies = "jointStudies", joint_contexts = "jointContexts", - joint_traits = "jointTraits" + joint_traits = "jointTraits", + region_given = "regionGiven" ) # The published columns that are structural or per-row, and so are never @@ -115,21 +116,22 @@ NULL # be uniformly "T" within a region would otherwise be type-guessed as logical, # silently corrupting the variant identity. # @noRd -.prdReadTable <- function(path, region, label) { +.prdReadTable <- function(path, which, label) { if (!file.exists(path)) { abort(glue("{label}: file '{path}' does not exist.")) } - if (!is.null(region)) { + if (!is.null(which)) { if (file.exists(str_c(path, ".tbi"))) { - return(.readTabixRegion(path, region)) + return(.readTabixRegion(path, which)) } warn(glue( - "{label}: '{path}' is not bgzipped + tabix-indexed; `region` ", + "{label}: '{path}' is not bgzipped + tabix-indexed; `which` ", "ignored, reading the whole file." )) } readr::read_tsv( path, + skip = length(.prdBedMetaLines(path)), show_col_types = FALSE, progress = FALSE, col_types = readr::cols(.default = readr::col_character()) @@ -156,8 +158,8 @@ NULL # off the `##SAMPLE` header block. Each sample is one fitted model, so each # contributes its own block of rows. # @noRd -.prdVcfTable <- function(path, region, sampleSelect, label) { - vcf <- .prdReadVcf(path, region, label) +.prdVcfTable <- function(path, which, sampleSelect, label) { + vcf <- .prdReadVcf(path, which, label) samples <- colnames(vcf) if (!is.null(sampleSelect)) { absent <- setdiff(as.character(sampleSelect), samples) @@ -185,27 +187,84 @@ NULL meta <- .prdVcfSampleMeta(vcf) pieces <- map(samples, .prdVcfSampleTable, vcf = vcf, meta = meta) list( + build = .prdVcfBuild(vcf), table = list_rbind(pieces), - fits = compact(set_names( - map(samples, .prdVcfPartialFit, meta = meta), - map_chr(pieces, .prdFirstKey) - )) + fits = compact(list_flatten(unname(map2( + samples, + pieces, + .prdVcfSampleFits, + meta = meta + )))) ) } -# The identity key of a sample's block, so its header-recorded partial fit can -# be found again once every sample's rows are stacked into one table. +# The genome build a VCF records on its ##reference line, or NA. +# @noRd +.prdVcfBuild <- function(vcf) { + .vcfMetaBuild(VariantAnnotation::header(vcf)) +} + +# @noRd +.vcfMetaBuild <- function(hdr) { + ref <- VariantAnnotation::meta(hdr)$reference + if (is.null(ref) || nrow(ref) == 0L) { + return(NA_character_) + } + as.character(ref$Value[[1L]]) +} + +# A sample's partial fits, keyed by the group each belongs to: one for a +# single fit, or one per LD block of a sample that joined several, taken from +# the header's "|"-packed values in the order its block list gives. The keys +# are the ones .prdGroups() splits the stacked table by, so each partial fit +# is found again once every sample's rows are stacked together. +# @noRd +.prdVcfSampleFits <- function(sample, tbl, meta) { + if (is.null(meta) || !is_in(sample, rownames(meta)) || nrow(tbl) == 0L) { + return(list()) + } + row <- meta[sample, , drop = FALSE] + keys <- .pubIdentityKey(tbl, .PRD_GROUP_COLS) + first <- which(!duplicated(keys)) + pos <- .prdBlockPositions(row, tbl$block_id[first]) %||% + rep(1L, length(first)) + set_names(map(pos, .prdVcfPartialFit, row = row), keys[first]) +} + +# Where each block sits in a joined sample's header lists, or NULL for a +# sample holding one block. +# @noRd +.prdBlockPositions <- function(row, blocks) { + listed <- .prdBlockList(row) + if (length(listed) < 2L || is.null(blocks) || all(is.na(blocks))) { + return(NULL) + } + # An NA block is a variant this sample does not have -- another sample of + # the file contributed it -- and it stays NA. + pos <- match(blocks, listed) + unknown <- !is.na(blocks) & is.na(pos) + if (any(unknown)) { + abort(glue( + "readFineMappingResult: the BID field names block(s) ", + "{str_flatten(unique(blocks[unknown]), ', ')} that the ", + "sample's header does not list." + )) + } + pos +} + +# The LD blocks a sample's `##SAMPLE` line lists, in packing order. # @noRd -.prdFirstKey <- function(tbl) { - cols <- intersect(.PRD_GROUP_COLS, names(tbl)) - if (nrow(tbl) == 0L || length(cols) == 0L) { - return("") +.prdBlockList <- function(row) { + cell <- row[["block_id"]] + if (is.null(cell) || is.na(cell[[1L]])) { + return(character(0)) } - .pubIdentityKey(tbl, cols)[[1L]] + str_split_1(as.character(cell[[1L]]), fixed("|")) } # @noRd -.prdReadVcf <- function(path, region, label) { +.prdReadVcf <- function(path, which, label) { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort(glue( "{label}: reading a published VCF requires the ", @@ -215,18 +274,18 @@ NULL if (!file.exists(path)) { abort(glue("{label}: file '{path}' does not exist.")) } - if (is.null(region) || !file.exists(str_c(path, ".tbi"))) { - if (!is.null(region)) { + if (is.null(which) || !file.exists(str_c(path, ".tbi"))) { + if (!is.null(which)) { warn(glue( "{label}: '{path}' is not bgzipped + tabix-indexed; ", - "`region` ignored, reading the whole file." + "`which` ignored, reading the whole file." )) } return(VariantAnnotation::readVcf(path)) } tf <- Rsamtools::TabixFile(path) gr <- .matchRegionSeqnames( - .asGRegion(region), + which, Rsamtools::seqnamesTabix(tf) ) if (is.null(gr)) { @@ -236,7 +295,7 @@ NULL } # The per-fit `##SAMPLE` block as a plain data.frame keyed by sample id, or -# NULL when the file has none. This is where `exportToVcf()` records the +# NULL when the file has none. This is where `writeGwasVcf()` records the # identity, the analysis window and the two per-EFFECT fit quantities (`V`, # `cs_index`) that no per-variant column could hold. # @noRd @@ -274,16 +333,30 @@ NULL end = as.integer(GenomicRanges::start(rr)), ID = names(rr) %||% rep(NA_character_, n), REF = unname(as.character(VariantAnnotation::ref(vcf))), - ALT = unname(map_chr(as.list(VariantAnnotation::alt(vcf)), .mlFirstAlt)) + ALT = .mlFirstAlts(VariantAnnotation::alt(vcf)) ) fmt <- set_names( map(names(geno), .prdVcfFormatColumn, geno = geno, sample = sample), map_chr(names(geno), .prdVcfKeyName) ) - ident <- .prdVcfIdentity(meta, sample, n) - bind_cols(fixed, as_tibble(fmt, .name_repair = "minimal"), ident) + # BID is structure, not a statistic: it says which LD block of a joined + # sample each variant belongs to, and so feeds the identity columns. + ident <- .prdVcfIdentity(meta, sample, n, fmt[["BID"]]) + fmt[["BID"]] <- NULL + # The records are the union of every sample's variants, and a sample + # leaves the cells of a variant it does not have empty. Those rows are + # not its results, so they are dropped rather than read back as variants + # with no statistics. + has <- reduce(map(fmt, .prdNotNa), `|`, .init = rep(FALSE, n)) + slice( + bind_cols(fixed, as_tibble(fmt, .name_repair = "minimal"), ident), + which(has) + ) } +# @noRd +.prdNotNa <- function(v) !is.na(v) + # One FORMAT field's column for one sample. A field the sample does not report # is all-NA, which is what an absent column means on the way back in. # @noRd @@ -302,7 +375,7 @@ NULL # A FORMAT key as the published column name. The fixed vocabulary is already # shared between the two formats, so only the per-credible-set `fullFit` -# fields need undoing: `exportToVcf()` uppercases those column names because a +# fields need undoing: `writeGwasVcf()` uppercases those column names because a # FORMAT key is conventionally uppercase, and nothing else in the schema is # case-ambiguous. # @noRd @@ -322,7 +395,7 @@ NULL # several merge into one identity-less row, and the reader's own arguments # supply whatever else is wanted. # @noRd -.prdVcfIdentity <- function(meta, sample, n) { +.prdVcfIdentity <- function(meta, sample, n, bid = NULL) { if (is.null(meta) || !is_in(sample, rownames(meta))) { return(tibble(study = rep(sample, length.out = n))) } @@ -339,13 +412,28 @@ NULL if (length(cols) == 0L) { return(tibble(study = rep(sample, length.out = n))) } + pos <- .prdBlockPositions(row, bid) out <- as_tibble( - set_names(map(cols, .prdMetaValue, row = row, n = n), cols), + set_names( + map(cols, .prdMetaValue, row = row, n = n, pos = pos), + cols + ), .name_repair = "minimal" ) .prdVcfRegionStart(out) } +# The header fields a sample joining several LD blocks packs one value per +# block of, separated by "|" (see writeGwasVcf). +# @noRd +.PRD_BLOCK_FIELDS <- c( + "block_id", + "region_id", + "region_start", + "region_end", + "region_given" +) + # A VCF header's `RegionStart` is 1-based, because VCF coordinates are; a # published table's `region_start` is 0-based half-open, because BED # coordinates are. Each format is right on its own terms, so the long form @@ -368,9 +456,17 @@ NULL # missing value and `.vcfHeaderValue()` writes it for a field one sample has # and another does not, so it is restored as NA rather than as the string ".". # @noRd -.prdMetaValue <- function(nm, row, n) { +.prdMetaValue <- function(nm, row, n, pos = NULL) { v <- as.character(row[[nm]][[1L]]) - rep(if (!is.na(v) && v == ".") NA_character_ else v, length.out = n) + if (is.na(v) || v == ".") { + return(rep(NA_character_, length.out = n)) + } + if (is.null(pos) || !is_in(nm, .PRD_BLOCK_FIELDS)) { + return(rep(v, length.out = n)) + } + # A joined sample: each variant takes its own block's value. + perBlock <- str_split_1(v, fixed("|"))[pos] + replace(perBlock, perBlock == "", NA_character_) } # The per-effect fit quantities the `##SAMPLE` block carried, as the partial @@ -381,13 +477,9 @@ NULL # the posterior matrices) is not published, so this is deliberately partial: # `NULL` when the header recorded neither. # @noRd -.prdVcfPartialFit <- function(meta, sample) { - if (is.null(meta) || !is_in(sample, rownames(meta))) { - return(NULL) - } - row <- meta[sample, , drop = FALSE] - v <- .prdUnpackNumeric(row[["V"]]) - csIndex <- .prdUnpackNumeric(row[["cs_index"]]) +.prdVcfPartialFit <- function(pos, row) { + v <- .prdUnpackNumeric(.prdBlockPiece(row[["V"]], pos)) + csIndex <- .prdUnpackNumeric(.prdBlockPiece(row[["cs_index"]], pos)) out <- compact(list( V = v, sets = if (!is.null(csIndex)) list(cs_index = as.integer(csIndex)) @@ -395,6 +487,22 @@ NULL if (length(out) == 0L) NULL else out } +# The `pos`-th block's part of a header cell: a sample joining several LD +# blocks packs one value per block, separated by "|", and a single-block +# sample's cell is its one value whole. +# @noRd +.prdBlockPiece <- function(cell, pos) { + if (is.null(cell) || length(cell) == 0L) { + return(NULL) + } + chr <- as.character(cell[[1L]]) + if (is.na(chr) || chr == "." || is.na(pos)) { + return(NULL) + } + pieces <- str_split_1(chr, fixed("|")) + if (length(pieces) == 1L) pieces else pieces[[pos]] +} + # A ";"-packed header value as a numeric vector, or NULL when it was NA. # @noRd .prdUnpackNumeric <- function(cell) { @@ -668,14 +776,45 @@ NULL # One published table read into the long form both readers work from. # @noRd -.prdRead <- function(path, region, format, sampleSelect, label) { +.prdRead <- function(path, which, format, sampleSelect, label) { assertString(path) + if (!is.null(which)) { + .assertRegionGRanges(which, "`which`") + } if (.prdFormat(path, format) == "vcf") { - return(.prdVcfTable(path, region, sampleSelect, label)) + return(.prdVcfTable(path, which, sampleSelect, label)) } # A published table has no header to carry a fit in -- only the VCF's # `##SAMPLE` block does -- so a BED read restores no fit at all. - list(table = .prdReadTable(path, region, label), fits = list()) + list( + table = .prdReadTable(path, which, label), + fits = list(), + build = .prdBedBuild(path) + ) +} + +# The genome build a published BED records on its `##genome=` line, or NA. +# @noRd +.prdBedBuild <- function(path) { + meta <- .prdBedMetaLines(path) + hit <- meta[str_detect(meta, "^##genome=")] + if (length(hit) == 0L) { + NA_character_ + } else { + str_remove(hit[[1L]], "^##genome=") + } +} + +# The `##` lines a published BED opens with, above its column header. +# @noRd +.prdBedMetaLines <- function(path) { + head <- readr::read_lines(path, n_max = 20L, progress = FALSE) + head[seq_len(.prdLeadingCount(str_detect(head, "^##")))] +} + +# @noRd +.prdLeadingCount <- function(flags) { + if (all(flags)) length(flags) else which(!flags)[[1L]] - 1L } # The row groups of a published table, in first-appearance order: one per @@ -773,6 +912,7 @@ NULL # file did not publish it. `region_start` is 0-based half-open like every # other published coordinate, so it is shifted back by one; `region_id` stays # the 1-based `chrom_start_end` identifier and is not a coordinate source. +# The chromosome is spelled in UCSC style, as the variants' ranges are. # @noRd .prdRowRegion <- function(df, idx, label) { start <- .prdGroupValue(df, "region_start", idx, label) @@ -782,7 +922,7 @@ NULL return(NULL) } GenomicRanges::GRanges( - chrom, + withChrPrefix(chrom), IRanges::IRanges( start = as.integer(start) + 1L, end = as.integer(end) @@ -821,7 +961,7 @@ NULL # back to the list method and hands back a list, which the constructor # then rejects as "not a GRanges". Names come from the group keys and # would otherwise land on the stored ranges. - unname(unlist(GenomicRanges::GRangesList(regions))) + unname(unlist(.rtlBindElements(regions))) } # A per-row character column for a constructor argument, or NULL when no row @@ -904,10 +1044,10 @@ NULL #' @title Read A Published Fine-Mapping Result #' @description Rebuild a \code{QtlFineMappingResult} or -#' \code{GwasFineMappingResult} from a file \code{\link{exportToBed}} or -#' \code{\link{exportToVcf}} wrote -- or from any file in the same -#' vocabulary, which is what makes this the way into pecotmr for results -#' produced elsewhere. +#' \code{GwasFineMappingResult} from a file \code{\link{writeBed}} or +#' \code{\link{writeGwasVcf}} wrote -- or from any file in +#' the same vocabulary, which is what makes this the way into pecotmr for +#' results produced elsewhere. #' #' A merged table holding several \code{(study, context, trait, method)} #' tuples reads back as a multi-row collection, one row per tuple. Which @@ -935,7 +1075,7 @@ NULL #' Every published quantity comes back identical, in either format. Three #' things are not identities: #' \itemize{ -#' \item \code{exportToBed()} publishes the \strong{filtered} top-loci +#' \item \code{writeBed()} publishes the \strong{filtered} top-loci #' table, so a default export holds the variants that passed #' \code{signalCutoff} / \code{minPurity} rather than every variant of #' the fit. Export with \code{signalCutoff = 0} for the whole table. @@ -950,11 +1090,11 @@ NULL #' } #' #' @param path Path to the published file. Bgzipped and tabix-indexed files -#' can be read by region. -#' @param region Optional region to restrict the read to -- a -#' \code{"chr:start-end"} string, a \code{GRanges}, or a one-row -#' \code{data.frame} with chrom/start/end. Ignored with a warning when the -#' file is not tabix-indexed. +#' can be read in part, with \code{which}. +#' @param which Optional \code{GRanges}: read only the records that overlap +#' it, as \code{which} does for \code{rtracklayer::import()} and +#' \code{VariantAnnotation::ScanVcfParam()}. Ignored with a warning when +#' the file is not tabix-indexed. #' @param format \code{"auto"} (default) reads a \code{.vcf} / \code{.bcf} #' path as a VCF and anything else as a published table; \code{"bed"} / #' \code{"vcf"} say so explicitly for a file named otherwise. @@ -975,12 +1115,12 @@ NULL #' \code{LBF}. These are an approximation under a prior you chose, not #' susie's \code{lbf_variable}, so nothing derives them unasked. #' @return A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. -#' @seealso \code{\link{exportToBed}}, \code{\link{exportToVcf}}, +#' @seealso \code{\link{writeBed}}, \code{\link{writeGwasVcf}}, #' \code{\link{readTwasWeights}} #' @examples #' data(qtlFineMappingExample) #' path <- file.path(tempdir(), "top_loci.bed") -#' exportToBed(qtlFineMappingExample, path) +#' writeBed(qtlFineMappingExample, path) #' # This fit predates the provenance columns, so its published table does #' # not say which genotype scale its posterior effects are on -- the reader #' # will not guess. @@ -990,7 +1130,7 @@ NULL #' @export readFineMappingResult <- function( path, - region = NULL, + which = NULL, format = c("auto", "bed", "vcf"), studyName = NULL, context = NULL, @@ -1002,7 +1142,7 @@ readFineMappingResult <- function( priorVariance = NULL ) { label <- "readFineMappingResult" - src <- .prdRead(path, region, format, sampleSelect, label) + src <- .prdRead(path, which, format, sampleSelect, label) df <- src$table .prdRequirePip(df, label) .prdRequireStandardized(df, weightStandardized, label) @@ -1024,7 +1164,10 @@ readFineMappingResult <- function( priorVariance = priorVariance, fits = src$fits ) - .prdBuildFineMapping(rows, df, context, trait, label) + .withGenome( + .prdBuildFineMapping(rows, df, context, trait, label), + src$build %||% NA_character_ + ) } # A fine-mapping result is a posterior, and the PIP is the posterior. A table @@ -1051,7 +1194,7 @@ readFineMappingResult <- function( list( fields = fields, region = .prdRowRegion(df, idx, label), - entry = fineMappingRow( + entry = FineMappingRow( variantIds = tl$variant_id, susieFit = .prdFitFor(fits, key), topLoci = tl @@ -1086,7 +1229,7 @@ readFineMappingResult <- function( return(.prdBuildQtl(rows, fields, regions, label)) } .prdRequireIdentity(fields, c("study", "method"), label) - GwasFineMappingResult( + out <- GwasFineMappingResult( studyName = .prdRowColumn(fields, "study"), method = .prdRowColumn(fields, "method"), entry = map(rows, "entry"), @@ -1096,6 +1239,22 @@ readFineMappingResult <- function( dataSource = .prdRowColumn(fields, "dataSource"), weightStandardized = .prdStandardizedColumn(fields) ) + .prdRestoreRegionGiven(out, rows) +} + +# Whether each block range was given is what the file says. The constructor +# counts every range it is handed as given, but a range read from a file is +# the analysis window, which says nothing of where it came from, so a file +# that does not record it reads back as computed. A group spanning several +# chromosomes is split into a row per chromosome, each keeping its group's. +# @noRd +.prdRestoreRegionGiven <- function(out, rows) { + recorded <- as.logical( + map_chr(map(rows, "fields"), .prdRowField, nm = "regionGiven") + ) + fromIdx <- .rtlSplitBySeqname(map(map(rows, "entry"), variants))$fromIdx + out$regionGiven <- !is.na(recorded[fromIdx]) & recorded[fromIdx] + out } @@ -1166,8 +1325,8 @@ readFineMappingResult <- function( #' @title Read Published TWAS Weights #' @description Rebuild a \code{TwasWeights} from a file -#' \code{\link{exportToBed}} or \code{\link{exportToVcf}} wrote, or from any -#' file in the same vocabulary. +#' \code{\link{writeBed}} or \code{\link{writeGwasVcf}} +#' wrote, or from any file in the same vocabulary. #' #' A merged table reads back as a multi-row collection, one row per #' \code{(study, context, trait, method)} tuple. A fitted model whose @@ -1194,17 +1353,17 @@ readFineMappingResult <- function( #' standardized genotype scale. Required when the file does not record it: #' the scale is not recoverable from the weights themselves. #' @return A \code{TwasWeights}. -#' @seealso \code{\link{exportToBed}}, \code{\link{readFineMappingResult}} +#' @seealso \code{\link{writeBed}}, \code{\link{readFineMappingResult}} #' @examples #' data(twasWeightsExample) #' path <- file.path(tempdir(), "weights.bed") -#' exportToBed(twasWeightsExample, path) +#' writeBed(twasWeightsExample, path) #' readTwasWeights(path) #' @export readTwasWeights <- function( path, - region = NULL, + which = NULL, format = c("auto", "bed", "vcf"), studyName = NULL, context = NULL, @@ -1215,7 +1374,7 @@ readTwasWeights <- function( sampleSelect = NULL ) { label <- "readTwasWeights" - src <- .prdRead(path, region, format, sampleSelect, label) + src <- .prdRead(path, which, format, sampleSelect, label) df <- src$table .prdRequireWgt(df, label) .prdRequireStandardized(df, weightStandardized, label) @@ -1234,7 +1393,7 @@ readTwasWeights <- function( supplied = supplied, label = label ) - .prdTwFromRows(rows, label) + .withGenome(.prdTwFromRows(rows, label), src$build %||% NA_character_) } # @noRd @@ -1294,7 +1453,7 @@ readTwasWeights <- function( list( fields = fields, region = .prdRowRegion(df, idx, label), - entry = twasWeightsRow( + entry = TwasWeightsRow( variantIds = tl$variant_id, weights = suppressWarnings(as.numeric(sub$WGT)), weightStandardized = isTRUE(.prdFlag(fields$standardized)), diff --git a/R/resultWriters.R b/R/resultWriters.R index 0bb61c8f..ac80dc36 100644 --- a/R/resultWriters.R +++ b/R/resultWriters.R @@ -4,11 +4,12 @@ # Every pecotmr output format that leaves the package as a FILE lives here, # behind TWO generics rather than one entry point per class: # -# exportToVcf(x, path, ...) GWAS-VCF-style: one record per variant, one -# SAMPLE per study / fitted model, the statistics -# as FORMAT fields. GwasSumStats, every -# FineMappingResultBase, TwasWeights. -# exportToBed(x, path, ...) the published long-format tables, one row per +# writeGwasVcf(obj, filename, ...) GWAS-VCF-style: one record per variant, +# one SAMPLE per study / fitted model, the +# statistics as FORMAT fields. GwasSumStats, +# every FineMappingResultBase, TwasWeights. +# VariantAnnotation (a Suggests) writes the file. +# writeBed(obj, filename, ...) the published long-format tables, one row per # published observation, bgzipped + tabix-indexed # on request. FineMappingResultBase, # TwasWeights. @@ -285,7 +286,7 @@ NULL } # Rows of a TwasWeights with no full-data weights: a CV-only row has an empty -# element AND no `weight` metadata column (twasWeightsRow() drops the column +# element AND no `weight` metadata column (TwasWeightsRow() drops the column # when `weights` is NULL). # @noRd .twbIncompleteRows <- function(x) { @@ -423,7 +424,8 @@ genomicOrder <- function(chrom, start, end = NULL) { index, emptySchema = .pubSchema(character(0)), keepColumns = character(0), - extraColumns = NULL + extraColumns = NULL, + build = NA_character_ ) { if (is.null(out) || nrow(out) == 0L) { # A header-only file documents the whole vocabulary rather than @@ -443,24 +445,30 @@ genomicOrder <- function(chrom, start, end = NULL) { if (nrow(out) > 0L) { out <- slice(out, genomicOrder(out[["#chr"]], out[["start"]])) } - .pubEmitTable(out, path, naString, index) + .pubEmitTable(out, path, naString, index, build) } # Materialise the ordered table at `path`, compressing and indexing it when the -# extension asks for it. +# extension asks for it. A named genome build goes first, as a `##genome=` +# line above the column header; tabix skips both as comments. # @noRd -.pubEmitTable <- function(out, path, naString, index) { +.pubEmitTable <- function(out, path, naString, index, build = NA_character_) { dir.create(dirname(path), showWarnings = FALSE, recursive = TRUE) compress <- str_detect(path, "\\.(gz|bgz)$") plain <- if (compress) str_remove(path, "\\.(gz|bgz)$") else path + con <- file(plain, "w") + if (!is.na(build)) { + writeLines(str_c("##genome=", build), con) + } utils::write.table( out, - plain, + con, sep = "\t", quote = FALSE, row.names = FALSE, na = naString ) + close(con) if (!compress) { return(invisible(path)) } @@ -475,18 +483,19 @@ genomicOrder <- function(chrom, start, end = NULL) { # ---- shared: output-path decoration ----------------------------------------- -# Decorate `outputPath` with the spec's context / trait tags when split flags -# are set. Preserves the file extension. Examples: "out.vcf" + (context="brain") -# -> "out.brain.vcf" "out.vcf.bgz" + (context="brain", trait="ENSG1") -> -# "out.brain.ENSG1.vcf.bgz" +# Decorate `outputPath` with the spec's context / trait / block tags when split +# flags are set. Preserves the file extension. Examples: "out.vcf" + +# (context="brain") -> "out.brain.vcf" "out.vcf.bgz" + (context="brain", +# trait="ENSG1") -> "out.brain.ENSG1.vcf.bgz" # @noRd .decorateOutputPath <- function( outputPath, spec, splitByContext, - splitByTrait + splitByTrait, + splitByBlock = FALSE ) { - if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { + if (!isTRUE(splitByContext) && !isTRUE(splitByTrait) && !splitByBlock) { return(outputPath) } ext <- str_to_lower(tools::file_ext(outputPath)) @@ -506,7 +515,8 @@ genomicOrder <- function(chrom, start, end = NULL) { ) tags <- c( if (isTRUE(splitByContext)) .pubPathTag(spec$context), - if (isTRUE(splitByTrait)) .pubPathTag(spec$trait) + if (isTRUE(splitByTrait)) .pubPathTag(spec$trait), + if (splitByBlock) .pubPathTag(spec$block) ) if (length(tags) == 0L) { return(outputPath) @@ -526,30 +536,30 @@ genomicOrder <- function(chrom, start, end = NULL) { # ---- VCF: entry points ------------------------------------------------------ -#' @rdname exportToVcf +#' @rdname writeGwasVcf #' @export setMethod( - "exportToVcf", + "writeGwasVcf", signature("list"), - function(x, outputPath, sampleName = NULL, ...) { - exportToVcf( - .pubCombineList(x), - outputPath, + function(obj, filename, sampleName = NULL, ...) { + writeGwasVcf( + .pubCombineList(obj), + filename, sampleName = sampleName, ... ) } ) -#' @rdname exportToVcf +#' @rdname writeGwasVcf #' @export setMethod( - "exportToVcf", + "writeGwasVcf", signature("GwasSumStats"), - function(x, outputPath, sampleName = NULL, studyName = NULL) { + function(obj, filename, sampleName = NULL, studyName = NULL) { .vcfRequireVariantAnnotation() - studyName <- .vcfResolveStudy(x, studyName) - ss <- sumStats(x, studyName = studyName) + studyName <- .vcfResolveStudy(obj, studyName) + ss <- sumStats(obj, studyName = studyName) mc <- mcols(ss) .writeVcfImpl( chrom = as.character(seqnames(ss)), @@ -560,16 +570,17 @@ setMethod( geno = .vcfSumstatsGeno(mc, length(ss)), genoHeader = .vcfSumstatsGenoHeader(), sampleName = sampleName %||% studyName, - outputPath = outputPath + outputPath = filename, + build = .oneBuild(obj) ) } ) -# VariantAnnotation is a Suggests, and every VCF path needs it. +# VariantAnnotation writes the file; it is a Suggests, so the writer checks. # @noRd .vcfRequireVariantAnnotation <- function() { if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { - abort("Package 'VariantAnnotation' is required for exportToVcf") + abort("Package 'VariantAnnotation' is required for writeGwasVcf().") } invisible(NULL) } @@ -581,14 +592,17 @@ setMethod( if (!is.null(studyName)) { return(studyName) } - if (nrow(x) != 1L) { + # Studies, not rows: one study is several rows once split by chromosome + # or LD block, and sumStats() stitches them back together. + studies <- unique(as.character(x$study)) + if (length(studies) != 1L) { msg <- glue( - "This GwasSumStats has {nrow(x)} studies. ", - "Pass `study = ` to select one." + "This GwasSumStats has {length(studies)} studies. ", + "Pass `studyName = ` to select one." ) abort(msg) } - as.character(x$study[[1L]]) + studies } # Per-sample geno matrices for the GWAS-VCF fields the mcols can fill. @@ -667,40 +681,41 @@ setMethod( ) } -#' @rdname exportToVcf +#' @rdname writeGwasVcf #' @export setMethod( - "exportToVcf", + "writeGwasVcf", signature("FineMappingResultBase"), function( - x, - outputPath, + obj, + filename, sampleName = NULL, studyName = NULL, context = NULL, trait = NULL, method = NULL, splitByContext = FALSE, - splitByTrait = FALSE + splitByTrait = FALSE, + splitByBlock = FALSE ) { .vcfRequireVariantAnnotation() + rows <- .pubMatchingRows(obj, studyName, context, trait, method) + .fitCoverageCheckedRows(obj[rows], "writeGwasVcf()") # Resolve what goes in each FILE. Without a split flag every matching - # fit is a SAMPLE of one file; with one, each fit gets its own file at - # a decorated path. + # fit is a SAMPLE of one file; with one, each context, trait or LD + # block gets its own file at a decorated path. groups <- .resolveFineMappingGroups( - x, - outputPath = outputPath, - studyName = studyName, - context = context, - trait = trait, - method = method, + obj, + outputPath = filename, + rows = rows, splitByContext = splitByContext, - splitByTrait = splitByTrait + splitByTrait = splitByTrait, + splitByBlock = splitByBlock ) invisible(map_chr( groups, .fmvWriteGroup, - x = x, + x = obj, sampleName = sampleName )) } @@ -709,66 +724,122 @@ setMethod( # Resolve what each OUTPUT FILE holds. Without a split flag every matching fit # becomes a SAMPLE of one multi-sample VCF -- which is GWAS-VCF's own shape, # where the samples are the studies -- so comparing two methods over a region -# means reading one file rather than two. `splitByContext` / `splitByTrait` -# still emit one single-sample file per fit, at a decorated path. +# means reading one file rather than two. A GWAS fit is every LD block of its +# (study, method), so its blocks share one sample. `splitByContext` / +# `splitByTrait` emit one file per context / trait and `splitByBlock` one per +# block, each at a decorated path; the fits that land on one path share it. # @noRd .resolveFineMappingGroups <- function( x, outputPath, - studyName, - context, - trait, - method, + rows, splitByContext, - splitByTrait + splitByTrait, + splitByBlock ) { - rows <- .pubMatchingRows(x, studyName, context, trait, method) if (length(rows) == 0L) { - abort("exportToVcf: no rows match the supplied selectors.") + abort("writeGwasVcf: no rows match the supplied selectors.") } - specs <- map(rows, .rowSpec, x = x) - if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { + .fmvCheckSplitByBlock(x, splitByBlock) + specs <- map( + .fmvFitRows(x, rows), + .fitSpec, + x = x, + blockIds = .fmvBlockIds(x) + ) + if (isTRUE(splitByBlock)) { + specs <- list_flatten(map(specs, .fmvSpecPerBlock)) + } + if (!isTRUE(splitByContext) && !isTRUE(splitByTrait) && !splitByBlock) { return(list(list(path = outputPath, specs = specs))) } - map( + paths <- map_chr( specs, - .fmvSplitGroup, + .decorateOutputPath, outputPath = outputPath, splitByContext = splitByContext, - splitByTrait = splitByTrait + splitByTrait = splitByTrait, + splitByBlock = splitByBlock ) + unname(imap( + split(specs, factor(paths, levels = unique(paths))), + .fmvPathGroup + )) } # @noRd -.fmvSplitGroup <- function(spec, outputPath, splitByContext, splitByTrait) { - list( - path = .decorateOutputPath( - outputPath, - spec, - splitByContext, - splitByTrait - ), - specs = list(spec) +.fmvPathGroup <- function(specs, path) { + list(path = path, specs = unname(specs)) +} + +# Blocks are a GWAS notion: a QTL fit is one row, so there is nothing to split. +# @noRd +.fmvCheckSplitByBlock <- function(x, splitByBlock) { + assertFlag(splitByBlock) + if (!splitByBlock || methods::is(x, "GwasFineMappingResult")) { + return(invisible(NULL)) + } + abort(glue( + "writeGwasVcf: `splitByBlock` splits a GWAS fit into its LD blocks; a ", + "{class(x)[[1L]]} fit is one row. Use `splitByContext` / ", + "`splitByTrait` instead." + )) +} + +# The matching rows grouped into fits, in first-appearance order. A GWAS fit is +# every LD block of one (study, method); a QTL row is a fit of its own, its +# joint-membership columns being part of what identifies it. +# @noRd +.fmvFitRows <- function(x, rows) { + if (!methods::is(x, "GwasFineMappingResult")) { + return(as.list(rows)) + } + key <- str_c( + .fmrIdentityColumn(x, "study")[rows], + .fmrIdentityColumn(x, "method")[rows], + sep = "\r" ) + unname(split(rows, factor(key, levels = unique(key)))) } -# Build a (study, context, trait, method) spec list for one row index. +# One spec per block of a fit, each carrying the block it is for. # @noRd -.rowSpec <- function(r, x) { +.fmvSpecPerBlock <- function(spec) { + map(unique(spec$blocks), .fmvBlockSpec, spec = spec) +} + +# @noRd +.fmvBlockSpec <- function(block, spec) { + on <- spec$blocks == block + list_assign( + spec, + rows = spec$rows[on], + blocks = spec$blocks[on], + block = block + ) +} + +# The LD block each row of a GWAS result covers: its `blockId`, which keys the +# block manifest, else its own range. +# @noRd +.fmvBlockIds <- function(x) { + ids <- .fmrIdentityColumn(x, "blockId") + if_else(is.na(ids), .rtlRangeKeys(x), ids) +} + +# Build a (study, context, trait, method) spec for one fit: its rows -- one, +# or one per LD block of a GWAS fit -- their blocks, and the identity they +# share. +# @noRd +.fitSpec <- function(rows, x, blockIds) { + r <- rows[[1L]] list( - row = r, - study = as.character(x$study)[r], - context = if (is_in("context", .tupleColumnNames(x))) { - as.character(x$context)[r] - } else { - NA_character_ - }, - trait = if (is_in("trait", .tupleColumnNames(x))) { - as.character(x$trait)[r] - } else { - NA_character_ - }, - method = as.character(x$method)[r] + rows = rows, + blocks = blockIds[rows], + study = .fmrIdentityAt(x, "study", r), + context = .fmrIdentityAt(x, "context", r), + trait = .fmrIdentityAt(x, "trait", r), + method = .fmrIdentityAt(x, "method", r) ) } @@ -980,7 +1051,10 @@ setMethod( error = function(cnd) NULL ) marg <- try_fetch( - as_tibble(marginalEffects(entry)), + as_tibble(as.data.frame( + S4Vectors::mcols(marginalEffects(entry)), + optional = TRUE + )), error = function(cnd) NULL ) hasPost <- !is.null(post) && nrow(post) > 0L @@ -992,7 +1066,7 @@ setMethod( base <- marg m <- marg } else { - msg <- glue("exportToVcf: entry [{sn}] has no variants to write") + msg <- glue("writeGwasVcf: entry [{sn}] has no variants to write") abort(msg) } list(base = base, m = m, hasPost = hasPost) @@ -1032,7 +1106,9 @@ setMethod( # variant leaves its cells empty. # @noRd .fmvWriteGroup <- function(group, x, sampleName) { - rows <- map(group$specs, .fmvRowSpecs, x = x) + # Every row's window at once: a genome-wide study's blocks join one + # sample, and asking per block would rebuild them all for each. + rows <- map(group$specs, .fmvRowSpecs, x = x, rg = genomicRegion(x)) sn <- .vcfSampleNames(map_chr(rows, "sampleName"), sampleName) variants <- .fmvVariantUnion(rows) specs <- keep( @@ -1049,38 +1125,144 @@ setMethod( genoHeader = .vcfGenoHeader(specs), sampleName = sn, outputPath = group$path, - sampleMeta = .fmvSampleMeta(rows, sn) + sampleMeta = .fmvSampleMeta(rows, sn), + build = .oneBuild(x) ) group$path } # One fit's body, its FORMAT specs, and the variants they are aligned to. # @noRd -.fmvRowSpecs <- function(spec, x) { - entry <- fineMappingResult( - x, - spec$study, - spec$context, - spec$trait, - spec$method - ) +.fmvRowSpecs <- function(spec, x, rg = genomicRegion(x)) { sn <- .fmvSampleLabel(spec) - body <- .vcfResolveBody(entry, sn) - nSnps <- nrow(body$base) + blocks <- map2( + spec$rows, + spec$blocks, + .fmvBlockBody, + x = x, + sn = sn, + rg = rg + ) + base <- bind_rows(map(blocks, "base")) + nSnps <- nrow(base) list( sampleName = sn, spec = spec, - perFit = .pubPerFitFields(x, spec$row, susieFit(entry)), - base = body$base, + perFit = .fmvJoinPerFit(map(blocks, "perFit")), + base = base, nVariants = nSnps, - variantIds = as.character(.pubCol(body$base, "variant_id", nSnps)), + variantIds = as.character(.pubCol(base, "variant_id", nSnps)), formats = c( - .vcfCoreSpecs(body$base, body$m, nSnps), - if (body$hasPost) .vcfPosteriorSpecs(body$base, nSnps) else list() + .vcfCoreSpecs(base, .fmvJoinMarginals(blocks), nSnps), + if (any(map_lgl(blocks, "hasPost"))) { + .vcfPosteriorSpecs(base, nSnps) + } else { + list() + }, + .fmvBlockIdSpec(blocks) ) ) } +# One row's body and its per-fit header values. A GWAS fit fine-mapped block +# by block is several rows, and each contributes one of these to the sample. +# @noRd +.fmvBlockBody <- function(r, block, x, sn, rg) { + entry <- x[r] + list_assign( + .vcfResolveBody(entry, sn), + perFit = .pubPerFitFields( + x, + r, + .fmrPartsSusieFit(.fmrRowParts(x, r)), + rg + ), + block = block + ) +} + +# The marginals of every block, row-aligned with the stacked bases. A block +# with none still holds its rows, as NA; with none anywhere the table has no +# columns, which the marginal fields read as missing, as they read NULL. +# @noRd +.fmvJoinMarginals <- function(blocks) { + bind_rows(map2(map(blocks, "m"), blocks, .fmvMarginalsOrEmpty)) +} + +# @noRd +.fmvMarginalsOrEmpty <- function(m, block) { + m %||% tibble(.rows = nrow(block$base)) +} + +# The BID field: each variant's LD block, written only when a sample joins +# several, since credible-set indices are numbered within a block. +# @noRd +.fmvBlockIdSpec <- function(blocks) { + if (length(blocks) < 2L) { + return(list()) + } + list(.vcfSpec( + "BID", + list_c(map(blocks, .fmvBlockColumn)), + "String", + "LD block of the variant; credible sets are numbered within a block" + )) +} + +# @noRd +.fmvBlockColumn <- function(block) { + rep(block$block, nrow(block$base)) +} + +# The per-fit header fields that differ between the blocks of one fit, packed +# in block order with "|" when a sample joins several. +# @noRd +.FMV_BLOCK_FIELDS <- c( + "block_id", + "region_id", + "region_start", + "region_end", + "region_given", + "V", + "cs_index" +) + +# The header values of a fit spread over several LD blocks: the per-block +# fields packed, the rest -- which describe the fit -- taken once, after +# checking every block agrees on them. +# @noRd +.fmvJoinPerFit <- function(perFits) { + if (length(perFits) == 1L) { + return(perFits[[1L]]) + } + fields <- names(perFits[[1L]]) + set_names(map(fields, .fmvJoinField, perFits = perFits), fields) +} + +# @noRd +.fmvJoinField <- function(nm, perFits) { + vals <- map_chr(perFits, .fmvFieldText, nm = nm) + if (all(is.na(vals))) { + return(NA_character_) + } + if (is_in(nm, .FMV_BLOCK_FIELDS)) { + return(str_flatten(replace_na(vals, ""), "|")) + } + if (n_distinct(vals) > 1L) { + abort(glue( + "writeGwasVcf: the LD blocks of one fit disagree on `{nm}` ", + "({str_flatten(unique(vals), ', ')}), so they cannot be written ", + "as one sample. Pass `splitByBlock = TRUE`." + )) + } + perFits[[1L]][[nm]] +} + +# @noRd +.fmvFieldText <- function(perFit, nm) { + as.character(perFit[[nm]] %||% NA_character_) +} + # @noRd .fmvSampleLabel <- function(spec) { as.character(glue( @@ -1150,7 +1332,12 @@ setMethod( # sample is missing a variant. # @noRd .fmvFormatColumn <- function(r, nm, unionIds, type) { - fill <- if (identical(type, "Integer")) NA_integer_ else NA_real_ + fill <- switch( + type, + Integer = NA_integer_, + String = NA_character_, + NA_real_ + ) out <- rep(fill, length(unionIds)) f <- .fmvFindFormat(r, nm) if (is.null(f)) { @@ -1197,6 +1384,7 @@ setMethod( region_id = "RegionId", region_start = "RegionStart", region_end = "RegionEnd", + region_given = "RegionGiven", V = "V", cs_index = "CsIndex" ) @@ -1233,9 +1421,11 @@ setMethod( # @noRd .fmvSampleMetaRow <- function(r) { + # As text: a sample joining several LD blocks packs its per-block fields + # into one string, and one header holds both kinds of sample. bind_cols( tibble(total_variants = r$nVariants), - as_tibble(r$perFit) + as_tibble(map(r$perFit, as.character)) ) } @@ -1249,8 +1439,7 @@ setMethod( # colocPipeline's row filter reads them off the fit -- `sets$cs_index` or `V`. # Without them a round-tripped LBF matrix could be read but not filtered. # @noRd -.pubPerFitFields <- function(x, row, fit) { - rg <- genomicRegion(x) +.pubPerFitFields <- function(x, row, fit, rg = genomicRegion(x)) { inRange <- !is.null(row) && length(rg) >= row md <- mcols(x) list( @@ -1268,6 +1457,7 @@ setMethod( region_id = if (inRange) .pubRegionIds(rg)[[row]] else NA_character_, region_start = if (inRange) start(rg)[[row]] else NA_integer_, region_end = if (inRange) end(rg)[[row]] else NA_integer_, + region_given = .pubRowValue(md, "regionGiven", row), V = .pubPackOrNa(.fitField(fit, "V")), cs_index = .pubPackOrNa(.fitField(fit, "sets", "cs_index")) ) @@ -1293,14 +1483,14 @@ setMethod( # ---- VCF: TWAS weights ------------------------------------------------------ -#' @rdname exportToVcf +#' @rdname writeGwasVcf #' @export setMethod( - "exportToVcf", + "writeGwasVcf", signature("TwasWeights"), function( - x, - outputPath, + obj, + filename, sampleName = NULL, studyName = NULL, context = NULL, @@ -1308,29 +1498,29 @@ setMethod( method = NULL ) { .vcfRequireVariantAnnotation() - .pubRequireFullFit(x, .twbIncompleteRows(x), "exportToVcf") - rows <- .pubMatchingRows(x, studyName, context, trait, method) + .pubRequireFullFit(obj, .twbIncompleteRows(obj), "writeGwasVcf") + rows <- .pubMatchingRows(obj, studyName, context, trait, method) if (length(rows) == 0L) { - abort("exportToVcf: no rows match the supplied selectors.") + abort("writeGwasVcf: no rows match the supplied selectors.") } # 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 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")) + rows <- intersect(rows, .twbExportableRows(obj, "writeGwasVcf")) if (length(rows) == 0L) { abort(str_c( - "exportToVcf: every selected row is fine-mapping-derived, so ", - "there is nothing to write as weights. Export the ", + "writeGwasVcf: every selected row is fine-mapping-derived, so ", + "there is nothing to write as weights. Write the ", "fine-mapping result." )) } .twvWriteSamples( - x, - .twvSampleSpecs(x, rows), + obj, + .twvSampleSpecs(obj, rows), sampleName, - outputPath + filename ) } ) @@ -1367,7 +1557,8 @@ setMethod( meta, colSums(!is.na(wgt)), x - ) + ), + build = .oneBuild(x) ) } @@ -1526,14 +1717,20 @@ setMethod( genoHeader, sampleName, outputPath, - sampleMeta = NULL + sampleMeta = NULL, + build = NA_character_ ) { - # Ensure chromosome names have the "chr" prefix. - if (!all(str_detect(chrom, "^chr"))) { - chrom <- str_c("chr", chrom) - } + # UCSC chromosome names (chr1, chrX, chrM), as the package's ranges use. + chrom <- withChrPrefix(chrom) gr <- .vcfBuildRanges(chrom, pos, ref, alt, snpIds) - hdr <- .vcfBuildHeader(sampleName, genoHeader, geno, sampleMeta) + hdr <- .vcfBuildHeader( + sampleName, + genoHeader, + geno, + sampleMeta, + build, + unique(chrom) + ) vcf <- .vcfBuildObject(gr, sampleName, hdr, geno, ref, alt) .vcfWriteByFormat(vcf, outputPath, chrom) invisible(outputPath) @@ -1552,12 +1749,31 @@ setMethod( ) } -# VCF header (VCFv4.2, the optional ##SAMPLE block, and the geno header subset -# to the fields actually present). +# VCF header (VCFv4.2, the genome build when the object names one, the +# optional ##SAMPLE block, and the geno header subset to the fields actually +# present). The build is written as ##reference and as the assembly of each +# ##contig, the two places a VCF reader looks for it. # @noRd -.vcfBuildHeader <- function(sampleName, genoHeader, geno, sampleMeta = NULL) { +.vcfBuildHeader <- function( + sampleName, + genoHeader, + geno, + sampleMeta = NULL, + build = NA_character_, + contigs = character(0) +) { + named <- !is.na(build) sections <- compact(list( fileformat = DataFrame(Value = "VCFv4.2", row.names = "fileformat"), + reference = if (named) { + DataFrame(Value = build, row.names = "reference") + }, + contig = if (named && length(contigs) > 0L) { + DataFrame( + assembly = rep(build, length(contigs)), + row.names = contigs + ) + }, SAMPLE = sampleMeta )) hdr <- VariantAnnotation::VCFHeader( @@ -1611,7 +1827,8 @@ setMethod( CharacterList(as.list(alt)) } -# Write the VCF in the format implied by the output extension. writeVcf appends +# Write the VCF in the format implied by the output extension. +# VariantAnnotation::writeVcf() appends # ".bgz" when index = TRUE, so paths are passed WITHOUT the .bgz/.gz suffix. # @noRd .vcfWriteByFormat <- function(vcf, outputPath, chrom) { @@ -1649,7 +1866,7 @@ setMethod( ), error = function(cnd) { msg <- glue( - "exportToVcf: BCF output needs a working ", + "writeGwasVcf: BCF output needs a working ", "Rsamtools::asBcf(), which the installed Rsamtools does not ", "provide. Write a bgzipped VCF instead by giving the output ", "path a .vcf.bgz extension." @@ -1659,7 +1876,8 @@ setMethod( ) } -# bgzip / gzip path: writeVcf always creates .bgz; rename to .gz on request. +# bgzip / gzip path: VariantAnnotation::writeVcf() always creates .bgz; +# renamed to .gz on request. # @noRd .vcfWriteBgz <- function(vcf, outputPath) { vcfStem <- str_remove(outputPath, "\\.(bgz|gz)$") @@ -1763,7 +1981,7 @@ setMethod( levels <- .pubCsLevels(view, coverage) if (length(levels) == 0L) { abort(str_c( - "exportToBed(schema = 'fsusie'): the result carries no ", + "writeBed(schema = 'fsusie'): the result carries no ", "credible-set column, so there are no rows to key on." )) } @@ -1896,18 +2114,21 @@ setMethod( if (nrow(fs) == 0L) { return(NULL) } - band <- as.data.frame(fsusieCredibleBand(fs)) + band <- as.data.frame( + S4Vectors::mcols(fsusieCredibleBand(fs)), + optional = TRUE + ) if (nrow(band) == 0L) { abort(str_c( - "exportToBed(schema = 'fsusie'): the functional fields ", + "writeBed(schema = 'fsusie'): the functional fields ", "are absent from every row. Refit with a retention level that ", "keeps the fSuSiE curves." )) } - csTbl <- as.data.frame(credibleSets(fs)) + csTbl <- as.data.frame(S4Vectors::mcols(credibleSets(fs)), optional = TRUE) primary <- .fmbPrimaryCsLevel(csTbl, coverage) csCols <- .pubCsColumns(csTbl, coverage) - marks <- as.data.frame(fsusieTraitEffects(fs)) + marks <- as.data.frame(.fsusieTraitEffectsTable(fs)) rowRegions <- genomicRegion(fs) rowRegionIds <- set_names( .pubRegionIds(rowRegions), @@ -2017,10 +2238,12 @@ setMethod( "joint_contexts", "joint_traits", # The window ANALYSED, without which a read-back result's genomicRegion() - # silently degrades to the span of the variants that survived QC. + # silently degrades to the span of the variants that survived QC, and, + # for a GWAS block, whether its range was given or is that span. "region_id", "region_start", - "region_end" + "region_end", + "region_given" ) # Always written, so the output is always a valid BED even when every optional @@ -2162,6 +2385,15 @@ setMethod( "p" ) +# The marginal estimates of `x`'s variants joined onto its posterior table. +# @noRd +.fmbMarginalsFor <- function(tl, x) { + .pubJoinMarginals( + tl, + as.data.frame(S4Vectors::mcols(marginalEffects(x)), optional = TRUE) + ) +} + # The topLoci BED table. # # `tl$beta`/`tl$se` are the POSTERIOR mean and sd -- topLoci() is the @@ -2178,7 +2410,7 @@ setMethod( if (nrow(tl) == 0L) { return(NULL) } - mm <- .pubJoinMarginals(tl, as.data.frame(marginalEffects(x))) + mm <- .fmbMarginalsFor(tl, x) win <- .fmbRowWindows(x, tl) pos <- .pubCol(tl, "pos") p <- suppressWarnings(as.numeric(.pubCol(mm, "p"))) @@ -2209,7 +2441,8 @@ setMethod( list( region_id = win$id, region_start = win$start, - region_end = win$end + region_end = win$end, + region_given = win$given ) ) out <- .pubFrame(cols, .pubSchema(csCols)) @@ -2282,13 +2515,19 @@ setMethod( ) } -# 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 ldReference. +# The fallback for `data_source`: a row's LD reference is the one its fit ran +# against, so a row with none is individual-level data. Only a fallback -- a +# row that recorded its own wins. Per row in .pubDataSourceOf(); for the +# collection as a whole it is NA when its rows are of both kinds. # @noRd .pubDataSource <- function(x) { - if (is.null(ldReference(x))) "individual" else "sumstat" + kinds <- unique(.pubDataSourceOf(x)) + if (length(kinds) == 1L) kinds else NA_character_ +} + +# @noRd +.pubDataSourceOf <- function(x) { + if_else(is.na(.ldRefKeys(x)), "individual", "sumstat") } # `EZ` only when the SOURCE supplied z. The spec defines the field as the z @@ -2324,14 +2563,18 @@ 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. +# window rather than the first one's. Both keys are built from the SAME +# columns -- those the view and the collection both carry -- since a GWAS view +# NA-fills a context and trait its collection does not have; and `blockId` is +# among them, as it is what tells the blocks of one GWAS fit apart. # @noRd .fmbRowWindows <- function(x, df) { rg <- genomicRegion(x) - idx <- match( - .pubIdentityKey(df, .PUB_ROW_COLS), - .pubCollectionKey(x, .PUB_ROW_COLS) + cols <- intersect( + intersect(c(.PUB_ROW_COLS, "blockId"), names(df)), + .tupleColumnNames(x) ) + idx <- match(.pubIdentityKey(df, cols), .pubCollectionKey(x, cols)) # 0-based half-open, like every other coordinate in a BED -- that is the # format's requirement, not a pecotmr choice. `region_id` stays the # canonical 1-based `chrom_start_end`, because it is an IDENTIFIER matched @@ -2339,19 +2582,30 @@ setMethod( list( id = .pubRegionIds(rg)[idx], start = start(rg)[idx] - 1L, - end = end(rg)[idx] + end = end(rg)[idx], + given = .pubRegionGiven(x)[idx] ) } +# Whether each row's block range was given, or NA where the collection does +# not record it (only a GWAS result does). +# @noRd +.pubRegionGiven <- function(x) { + if (!is_in("regionGiven", .tupleColumnNames(x))) { + return(rep(NA, nrow(x))) + } + as.logical(.tupleColumn(x, "regionGiven")) +} + # ---- BED: fine-mapping entry point ------------------------------------------ -#' @rdname exportToBed +#' @rdname writeBed #' @export setMethod( - "exportToBed", + "writeBed", signature("list"), - function(x, outputPath, ...) { - exportToBed(.pubCombineList(x), outputPath, ...) + function(obj, filename, ...) { + writeBed(.pubCombineList(obj), filename, ...) } ) @@ -2359,14 +2613,14 @@ setMethod( # window each row was ANALYSED over. A nominal TAD boundary is what a # publication table means by its region, not the narrower span of whichever # variants survived QC. -#' @rdname exportToBed +#' @rdname writeBed #' @export setMethod( - "exportToBed", + "writeBed", signature("FineMappingResultBase"), function( - x, - outputPath, + obj, + filename, schema = c("topLoci", "fsusie"), signalCutoff = 0.025, minPurity = NULL, @@ -2377,25 +2631,27 @@ setMethod( ) { schema <- arg_match(schema) levels <- arg_match(levels, multiple = TRUE) - assertString(outputPath) - .pubRequireFullFit(x, .fmbIncompleteRows(x), "exportToBed") + assertString(filename) + .pubRequireFullFit(obj, .fmbIncompleteRows(obj), "writeBed") if (identical(schema, "fsusie")) { return(.pubWriteTable( - .fmbFsusieTable(x, columns, levels, coverage), - outputPath, + .fmbFsusieTable(obj, columns, levels, coverage), + filename, naString = "NA", index = TRUE, emptySchema = .fmbFsusieColumns(levels), - extraColumns = extraColumns + extraColumns = extraColumns, + build = .oneBuild(obj) )) } .pubWriteTable( - .fmbTopLociTable(x, signalCutoff, minPurity, columns, coverage), - outputPath, + .fmbTopLociTable(obj, signalCutoff, minPurity, columns, coverage), + filename, naString = "NA", index = TRUE, keepColumns = .pubNamedColumns(columns), - extraColumns = extraColumns + extraColumns = extraColumns, + build = .oneBuild(obj) ) } ) @@ -2441,7 +2697,7 @@ setMethod( method = .pubTupleColumn("method", x), standardized = .twbColumnOr(x, "standardized", as.logical, NA), dataType = .twbListColumn(x, "dataType"), - dataSource = .pubDataSource(x), + dataSource = .pubDataSourceOf(x), jointStudies = .twbColumnOr( x, "jointStudies", @@ -2523,7 +2779,7 @@ setMethod( ) # @noRd -.twbExportableRows <- function(x, label = "exportToBed") { +.twbExportableRows <- function(x, label = "writeBed") { methods <- .pubTupleColumn("method", x) skip <- which(is_in(methods, .TWB_FINE_MAPPING_METHODS)) if (length(skip) > 0L) { @@ -2614,21 +2870,20 @@ setMethod( start = start(regions)[[i]] - 1L, end = end(regions)[[i]] ), - af = .twbVariantAf(x, gr), + af = .twbVariantAf(.rowLdRef(x, i), gr), schema = schema, added = added )) } -# 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. +# Per-variant allele frequency, from the row'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) { - ref <- ldReference(x) +.twbVariantAf <- function(ref, gr) { af <- if (is.null(ref)) NULL else .ldRefAf(ref) if (is.null(af)) { return(NA_real_) @@ -2642,7 +2897,7 @@ setMethod( rows <- .twbExportableRows(x) if (length(rows) == 0L) { abort(str_c( - "exportToBed: every row is fine-mapping-derived, so there is ", + "writeBed: every row is fine-mapping-derived, so there is ", "nothing to write as weights. Export the fine-mapping result." )) } @@ -2672,27 +2927,28 @@ setMethod( # held-out FOLDS, nothing about them is per-variant, and a published file has # no data-secure way to express anything fold-level. They stay on the object, # where cvResult() returns them and the caller tabulates whatever they need. -#' @rdname exportToBed +#' @rdname writeBed #' @export setMethod( - "exportToBed", + "writeBed", signature("TwasWeights"), function( - x, - outputPath, + obj, + filename, coverage = NULL, columns = NULL, extraColumns = NULL ) { - assertString(outputPath) - .pubRequireFullFit(x, .twbIncompleteRows(x), "exportToBed") + assertString(filename) + .pubRequireFullFit(obj, .twbIncompleteRows(obj), "writeBed") .pubWriteTable( - .twbWeightsTable(x, columns, coverage), - outputPath, + .twbWeightsTable(obj, columns, coverage), + filename, naString = "NA", index = TRUE, keepColumns = .pubNamedColumns(columns), - extraColumns = extraColumns + extraColumns = extraColumns, + build = .oneBuild(obj) ) } ) diff --git a/R/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 0e277c5f..2d03dff8 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -176,8 +176,8 @@ sldscPostprocessingPipeline <- function( # first single run. # @noRd .sldscPivotRun <- function(sldscData, trait1) { - pivotRun <- sldscResults(sldscData, trait1, "joint") %||% - sldscResults(sldscData, trait1, "single", 1L) + pivotRun <- .sldscRun(sldscData, trait1, "joint") %||% + .sldscRun(sldscData, trait1, "single", 1L) pivotRun } @@ -242,7 +242,7 @@ sldscPostprocessingPipeline <- function( # Baseline categories = the first trait's joint categories minus the targets. # @noRd .sldscBaselineCategories <- function(sldscData, traitNames, targetCategories) { - jointPivot <- sldscResults(sldscData, traitNames[1], "joint") + jointPivot <- .sldscRun(sldscData, traitNames[1], "joint") baselineCategories <- if (!is.null(jointPivot)) { setdiff(jointPivot$categories, targetCategories) } else { @@ -319,7 +319,7 @@ sldscPostprocessingPipeline <- function( # list(singleDf, blocksSingle, singleH2gs). # @noRd .sldscTraitSingle <- function(trait, ctx) { - singleRuns <- sldscResults(ctx$sldscData, trait, "single") %||% list() + singleRuns <- .sldscRun(ctx$sldscData, trait, "single") %||% list() nRun <- min(length(ctx$targetCategories), length(singleRuns)) stds <- compact(map( seq_len(nRun), @@ -395,7 +395,7 @@ sldscPostprocessingPipeline <- function( jointH2g = NA_real_, nBlocks = NA_integer_ ) - if (is.null(sldscResults(ctx$sldscData, trait, "joint"))) { + if (is.null(.sldscRun(ctx$sldscData, trait, "joint"))) { return(empty) } std <- try_fetch( diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 61a0f5a3..d9b12bd6 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -37,7 +37,7 @@ #' tidy list ready for downstream standardization. Hides the underlying file #' formats; downstream code consumes only modeling quantities. #' -#' @param prefix Character. Path prefix to the polyfun outputs for one +#' @param path Character. Path prefix to the polyfun outputs for one #' trait/run. The function appends `.results`, `.log`, and `.part_delete` to #' this prefix. Example: `"/path/to/cwd/CAD_META.filtered.sumstats.gz"`. #' @@ -55,8 +55,8 @@ #' @importFrom vroom vroom #' @importFrom readr read_lines #' @export -readSldscTrait <- function(prefix) { - files <- str_c(prefix, c(".results", ".log", ".part_delete")) +readSldscTrait <- function(path) { + files <- str_c(path, c(".results", ".log", ".part_delete")) assertFileExists(files, access = "r", .var.name = "readSldscTrait input") results <- vroom(files[1], show_col_types = FALSE) cats <- as.character(results$Category) @@ -133,7 +133,7 @@ readSldscTrait <- function(prefix) { #' (\code{\link{computeSldscAnnotSd}}, \code{\link{isBinarySldscAnnot}}) then #' runs on the loaded table, not on paths. #' -#' @param targetAnnoDir Character. Directory of `.annot.gz` files. +#' @param path Character. Directory of `.annot.gz` files. #' @param annotCols Character or integer vector, default NULL. Annotation #' columns to keep. NULL keeps all non-standard columns (auto-detected). #' @return A \code{data.frame}: \code{CHR}, \code{SNP}, and annotation columns. @@ -143,19 +143,19 @@ readSldscTrait <- function(prefix) { #' sldsc <- system.file("extdata", "sldsc", package = "pecotmr") #' readSldscAnnot(sldsc) #' @export -readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { +readSldscAnnot <- function(path, annotCols = NULL) { assertDirectoryExists( - targetAnnoDir, + path, access = "r", - .var.name = "targetAnnoDir" + .var.name = "path" ) annoFiles <- list.files( - targetAnnoDir, + path, pattern = "\\.annot\\.gz$", full.names = TRUE ) if (length(annoFiles) == 0L) { - msg <- glue("readSldscAnnot: no .annot.gz files in: {targetAnnoDir}") + msg <- glue("readSldscAnnot: no .annot.gz files in: {path}") abort(msg) } @@ -184,7 +184,7 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { #' \code{SNP}, \code{MAF}. Feeds the \code{frq} slot of #' \code{\link{SldscData}}. #' -#' @param frqfileDir Character. Directory of `.frq` files. +#' @param path Character. Directory of `.frq` files. #' @param plinkName Character. Filename prefix (files at #' `.frq`). Falls back to all `*.frq` in the directory when #' the prefix matches nothing. @@ -195,8 +195,8 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { #' sldsc <- system.file("extdata", "sldsc", package = "pecotmr") #' head(readSldscFrq(sldsc, plinkName = "reference.")) #' @export -readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { - assertDirectoryExists(frqfileDir, access = "r", .var.name = "frqfileDir") +readSldscFrq <- function(path, plinkName = "ADSP_chr") { + assertDirectoryExists(path, access = "r", .var.name = "path") pat <- str_c( "^", str_replace_all(plinkName, "([.])", "\\\\\\1"), @@ -204,14 +204,14 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { ) # The per-chromosome pattern first; a directory holding a single # unnumbered .frq falls back to the bare extension. - matched <- list.files(frqfileDir, pattern = pat, full.names = TRUE) + matched <- list.files(path, pattern = pat, full.names = TRUE) frqFiles <- if (length(matched) > 0L) { matched } else { - list.files(frqfileDir, pattern = "\\.frq$", full.names = TRUE) + list.files(path, pattern = "\\.frq$", full.names = TRUE) } if (length(frqFiles) == 0L) { - msg <- glue("readSldscFrq: no .frq files in: {frqfileDir}") + msg <- glue("readSldscFrq: no .frq files in: {path}") abort(msg) } @@ -267,8 +267,8 @@ readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { #' @export computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { assertClass(sldscData, "SldscData") - annot <- annotData(sldscData) - frq <- frqData(sldscData) + annot <- .sdAnnot(sldscData) + frq <- .sdFrq(sldscData) if (mafCutoff > 0 && nrow(frq) == 0L) { msg <- glue( "computeSldscAnnotSd: mafCutoff = {mafCutoff} requires frq ", @@ -391,7 +391,7 @@ computeSldscAnnotSd <- function(sldscData, mafCutoff = 0.05, annotCols = NULL) { #' @export computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { assertClass(sldscData, "SldscData") - frq <- frqData(sldscData) + frq <- .sdFrq(sldscData) if (nrow(frq) > 0L) { return(as.integer( if (mafCutoff > 0) { @@ -408,7 +408,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { ) abort(msg) } - as.integer(nrow(annotData(sldscData))) + as.integer(nrow(.sdAnnot(sldscData))) } @@ -453,7 +453,7 @@ computeSldscMRef <- function(sldscData, mafCutoff = 0.05) { #' @export isBinarySldscAnnot <- function(sldscData, annotCols = NULL) { assertClass(sldscData, "SldscData") - annot <- annotData(sldscData) + annot <- .sdAnnot(sldscData) colsUse <- if (is.null(annotCols)) { annotCols(sldscData) } else if (is.numeric(annotCols)) { @@ -585,7 +585,7 @@ standardizeSldscTrait <- function( # Fetch the requested trait's single/joint run (error when absent). # @noRd .stdTraitRun <- function(sldscData, trait, mode, idx) { - traitData <- sldscResults(sldscData, trait, mode, idx) + traitData <- .sldscRun(sldscData, trait, mode, idx) if (is.null(traitData)) { idxNote <- if (!is.null(idx)) glue(" (idx={idx})") else "" msg <- glue( diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index 48ea8998..9798ae60 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -334,7 +334,7 @@ resolveLdInput <- function( #' @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} +#' \code{duprThreshold}, \code{BPPARAM}, \code{correctChenEtAlBug} #' and \code{seed}. This is the same record #' \code{\link{ldMismatchQc}} takes as #' \code{method = DentistParam(...)}, so a setting means the same thing @@ -529,7 +529,7 @@ dentist <- function( p$gcControl, as.integer(p$nIter), p$gPvalueThreshold, - as.integer(p$numThreads), + p$threads, p$correctChenEtAlBug, verboseIter, if (is.null(p$seed)) NULL else as.integer(p$seed) @@ -593,7 +593,10 @@ dentist <- function( #' @param nIter Number of iterations. Default is 10. #' @param gPvalueThreshold Grouping p-value threshold. Default is 0.05. #' @param duprThreshold Duplicate r-squared threshold. Default is 0.99. -#' @param numThreads Number of CPU cores. Default is 1. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the +#' threads DENTIST's OpenMP loops use when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' thread. Default \code{SerialParam()}. #' @param correctChenEtAlBug Correct the original DENTIST operator! bug. Default #' is TRUE. #' @param ldMethod Character string specifying the LD computation method when @@ -626,11 +629,12 @@ dentistSingleWindow <- function( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - numThreads = 1, + BPPARAM = SerialParam(), correctChenEtAlBug = TRUE, ldMethod = "sample", seed = NULL ) { + .assertBpparam(BPPARAM) ld <- .dentistLdInput(R, X, nSample, ldMethod) nSample <- ld$nSample .dentistValidateInput(zScore, ld) @@ -640,7 +644,7 @@ dentistSingleWindow <- function( gcControl = gcControl, nIter = nIter, gPvalueThreshold = gPvalueThreshold, - numThreads = numThreads, + threads = .bpLocalThreads(BPPARAM, "dentistSingleWindow"), correctChenEtAlBug = correctChenEtAlBug, seed = seed ) @@ -1487,7 +1491,12 @@ slalom <- function( #' @param df Data frame. Contains information about Credible Sets for a specific #' study and block. #' @param highCorrCols Character vector. Names of columns in df that represent -#' high correlations. +#' high correlations; a non-top CS whose value in any of them is 1 is +#' tagged. A CS's own column of \code{\link{extractCsInfo}}'s between-CS +#' correlations (\code{cs_corr_} for row \code{i}, its self-correlation) +#' is never read, so passing every \code{cs_corr_*} column tags a CS only by +#' its correlation with the other sets. Rows are taken in +#' \code{extractCsInfo()}'s order. #' #' @return A modified data frame with additional columns attached to the #' diagnostic table: @@ -1649,9 +1658,9 @@ autoDecision <- function(df, highCorrCols) { # reference this dominates: 43 observed multi-allelic positions produced 2969 # imputed variants in one block before this guard. # -# Keyed on canonical (chrom, pos) so a "chr1"/"1" difference does not read as -# two different sites. A position with no GWAS observation still imputes every -# panel form it has, multi-allelic included. +# Keyed on (chrom, pos), which raiss() spells in UCSC style on both tables. A +# position with no GWAS observation still imputes every panel form it has, +# multi-allelic included. # @noRd .raissObservedPosition <- function(refPanel, knownZ) { n <- nrow(refPanel) @@ -1664,10 +1673,10 @@ autoDecision <- function(df, highCorrCols) { ) } -# Canonical "chrom:pos" keys, so a "chr1"/"1" difference is one site. +# "chrom:pos" keys. # @noRd .raissPositionKey <- function(chrom, pos) { - str_c(canonChrom(as.character(chrom)), ":", as.character(pos)) + str_c(as.character(chrom), ":", as.character(pos)) } # Imputation targets: panel rows the sumstats do not carry, minus the rows no @@ -1988,29 +1997,56 @@ raissSingleMatrixFromX <- function( } # 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. +# Known and imputed rows are merged on chrom, so known z-scores on none of the +# reference's chromosomes have nothing to impute from; say so here rather +# than in an empty join. # @noRd .raissRefPanelOf <- function(ref, knownZscores) { panel <- .refVariantsFromLdRef(ref) - sameLabels <- is.character(knownZscores$chrom) && - any(is_in(knownZscores$chrom, panel$chrom)) - if (!sameLabels) { + if (!any(is_in(knownZscores[["chrom"]], panel$chrom))) { abort(c( - str_c( - "`knownZscores$chrom` must use the LD reference's chromosome ", - "labels." - ), + "`knownZscores` shares no chromosome with the LD reference.", i = glue( - "They are canonical character labels, like ", - "'{panel$chrom[[1L]]}'." + "The reference covers ", + "{str_flatten(unique(panel$chrom), ', ')}." ) )) } panel } +# knownZscores as raiss() reads it: a table as given, or a summary-statistics +# entry -- the GRanges sumStats() returns -- as the table summaryStatsQc() +# builds from one. +# @noRd +.raissKnownTable <- function(knownZscores) { + if (!methods::is(knownZscores, "GRanges")) { + return(knownZscores) + } + need <- c("SNP", "A1", "A2", "Z") + absent <- setdiff(need, colnames(mcols(knownZscores))) + if (length(absent) > 0L) { + abort(c( + glue( + "`knownZscores` as a GRanges lacks column(s) ", + "{str_flatten(absent, ', ')}." + ), + i = "Pass a summary-statistics entry, as sumStats(x) returns it." + )) + } + .qcRaissKnownZ(.entryGrangesToDf(knownZscores)) +} + +# A table handed to raiss() with its `chrom` column in UCSC style, so its rows +# meet the reference's and each other's on equal labels. NULL stays NULL. +# @noRd +.raissUcscChrom <- function(df) { + if (is.null(df) || is.null(df[["chrom"]])) { + return(df) + } + `[[<-`(df, "chrom", value = withChrPrefix(df[["chrom"]])) +} + # 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. @@ -2042,11 +2078,15 @@ raissSingleMatrixFromX <- function( #' #' @param refPanel A data frame containing 'chrom', 'pos', 'variant_id', 'A1', #' 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. +#' panel, whose own variants are used. 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. +#' 'A1', 'A2', and 'z' values, or a summary-statistics \code{GRanges} -- +#' one entry as \code{\link{sumStats}} returns it, with its \code{SNP}, +#' \code{A1}, \code{A2} and \code{Z} columns. Here and in \code{refPanel} +#' a chromosome may be labelled in any style (\code{22}, \code{"22"}, +#' \code{"chr22"}); both are read in UCSC style (\code{"chr22"}), which +#' the result uses. #' @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. @@ -2107,6 +2147,8 @@ raiss <- function( if (is.null(genotypes) && is.null(ldMatrix)) { abort("Provide either ldMatrix or genotypes.") } + knownZscores <- .raissUcscChrom(.raissKnownTable(knownZscores)) + refPanel <- .raissUcscChrom(refPanel) ref <- .raissReferenceOf(ldMatrix, genotypes) if (!is.null(ref)) { refPanel <- refPanel %||% .raissRefPanelOf(ref, knownZscores) @@ -2178,7 +2220,12 @@ setClass( #' this and \code{mafCutoff} applies. Default \code{0}. #' @param imissCutoff Missingness ceiling for a target. Default \code{1}. #' @param flank Base pairs by which to widen the analysis-region window on -#' each side, retaining LD context for edge variants. Default \code{0}. +#' each side, retaining LD context for edge variants. The window never +#' widens into another row of the same study on its chromosome -- the +#' neighbouring LD block of a block-split GWAS -- since that row imputes +#' its own variants, nor past a row's block range where that was given +#' (\code{regionGiven}, see \code{\linkS4class{GwasSumStats}}). Default +#' \code{0}. #' @return A \code{RaissParam} object, a \code{\link{MethodParam}}. #' @seealso \code{\link{summaryStatsQc}}, \code{\link{raiss}} #' @examples @@ -2244,10 +2291,17 @@ raissModel <- function( batch = TRUE, reportConditionNumber = FALSE ) { - sigTInv <- invertMatRecursive(sigT, lamb, rcond) - assertNumeric(zt) + # Checked before sigT is used: the inversion retries on any error, so a + # bad input would otherwise surface as base R's error from its third try. + # sigT is the known x known LD and sigIT the unknown x known LD, so both + # carry one column per known z-score. + assertNumeric(zt, min.len = 1L) assertNumeric(sigT) assertNumeric(sigIT) + k <- length(zt) + assertMatrix(sigT, nrows = k, ncols = k) + assertMatrix(sigIT, min.rows = 1L, ncols = k) + sigTInv <- invertMatRecursive(sigT, lamb, rcond) checks <- .raissInversionChecks( sigT, sigTInv, @@ -2605,7 +2659,7 @@ setClass( nIter = "numeric", gPvalueThreshold = "numeric", duprThreshold = "numeric", - numThreads = "numeric", + BPPARAM = "BiocParallelParam", correctChenEtAlBug = "logical", seed = "numeric_OR_NULL" ) @@ -2626,7 +2680,10 @@ setClass( #' @param nIter Number of DENTIST iterations. Default \code{10}. #' @param gPvalueThreshold Grouping p-value threshold. Default \code{0.05}. #' @param duprThreshold Duplicate r-squared threshold. Default \code{0.99}. -#' @param numThreads Number of CPU cores. Default \code{1}. +#' @param BPPARAM A \code{BiocParallelParam} whose workers number the +#' threads DENTIST's OpenMP loops use when they run on this machine +#' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +#' thread. Default \code{SerialParam()}. #' @param correctChenEtAlBug Logical; apply the Chen et al. correction. #' Default \code{TRUE}. #' @param seed Integer or \code{NULL}. Random seed for the iteration. @@ -2641,7 +2698,7 @@ DentistParam <- function( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - numThreads = 1, + BPPARAM = SerialParam(), correctChenEtAlBug = TRUE, seed = NULL ) { @@ -2653,7 +2710,7 @@ DentistParam <- function( nIter = nIter, gPvalueThreshold = gPvalueThreshold, duprThreshold = duprThreshold, - numThreads = numThreads, + BPPARAM = .assertBpparam(BPPARAM), correctChenEtAlBug = correctChenEtAlBug, seed = seed ) @@ -2811,10 +2868,7 @@ effectiveN <- function(nCase, nControl) { .entryGrangesToDf <- function(gr) { mc <- as.data.frame(S4Vectors::mcols(gr), stringsAsFactors = FALSE) out <- tibble( - chrom = str_remove( - as.character(GenomicRanges::seqnames(gr)), - regex("^chr", ignore_case = TRUE) - ), + chrom = as.character(GenomicRanges::seqnames(gr)), pos = GenomicRanges::start(gr) ) bind_cols(out, mc) @@ -3014,6 +3068,41 @@ effectiveN <- function(nCase, nControl) { mutate(df, z = .data$beta / .data$se) } +# One tuple of a GwasSumStats / QtlSumStats collection as the flat table +# .entryToSumstatDf() builds. `studyName` / `context` / `trait` select the +# tuple as sumStats() does; a GWAS takes `studyName` only. +# @noRd +.sumStatsDf <- function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + require = character(0), + derive = c("none", "zFromBetaSe") +) { + .entryToSumstatDf( + sumStats(x, studyName = studyName, context = context, trait = trait), + require = require, + derive = derive, + label = .sumStatsDfLabel(x, studyName, context, trait) + ) +} + +# The tuple a .sumStatsDf() error names; "" marks a selector left to +# resolve on its own. +# @noRd +.sumStatsDfLabel <- function(x, studyName, context, trait) { + parts <- c( + studyName %||% "", + context %||% "", + trait %||% "" + ) + if (is(x, "GwasSumStats")) { + parts <- parts[[1L]] + } + glue("{class(x)[[1L]]}[{str_flatten(parts, '/')}]") +} + # Derive BETA and SE columns from signed Z when the entry has only Z. # Formula (Zhu et al. 2016 / RAISS): # se = 1 / sqrt(2 * maf * (1 - maf) * (N + z^2)) @@ -3157,42 +3246,17 @@ effectiveN <- function(nCase, nControl) { list(df = derived, audit = list(nDerived = sum(!is.na(se)))) } -# Drop variants whose (chrom, pos) overlaps any user-supplied skipRegion. -# skipRegion may be a character vector of "chr:start-end" strings or a GRanges. -# Parse one 'chr:start-end' skip-region string into a 1-row data.frame. -.parseSkipRegionEntry <- function(s) { - m <- str_match(s, "^([^:]+):([0-9]+)-([0-9]+)$")[1L, ] - if (is.na(m[[1L]])) { - msg <- glue("skipRegion entry must be 'chr:start-end'; got '{s}'") - abort(msg) - } - tibble( - chrom = str_remove(m[[2L]], regex("^chr", ignore_case = TRUE)), - start = as.integer(m[[3L]]), - end = as.integer(m[[4L]]) - ) -} - -# Normalise skipRegion (character vector or GRanges) to a chrom/start/end frame. +# Drop variants whose (chrom, pos) overlaps any user-supplied skipRegion, a +# GRanges -- as every window given in R is. +# Normalise skipRegion to a chrom/start/end frame. +# @noRd .parseSkipRegion <- function(skipRegion) { - if (is.character(skipRegion)) { - return(bind_rows(map(skipRegion, .parseSkipRegionEntry))) - } - if (methods::is(skipRegion, "GRanges")) { - return(tibble( - chrom = str_remove( - as.character(GenomicRanges::seqnames(skipRegion)), - regex("^chr", ignore_case = TRUE) - ), - start = GenomicRanges::start(skipRegion), - end = GenomicRanges::end(skipRegion) - )) - } - msg <- glue( - "skipRegion must be a character vector of 'chr:start-end' ", - "strings or a GRanges." + skipRegion <- .assertRegionGRanges(skipRegion, "`skipRegion`") + tibble( + chrom = as.character(GenomicRanges::seqnames(skipRegion)), + start = GenomicRanges::start(skipRegion), + end = GenomicRanges::end(skipRegion) ) - abort(msg) } # Rows falling inside skip region `i`. @@ -3206,10 +3270,7 @@ effectiveN <- function(nCase, nControl) { return(df) } parsed <- .parseSkipRegion(skipRegion) - dfChr <- str_remove( - as.character(df$chrom), - regex("^chr", ignore_case = TRUE) - ) + dfChr <- as.character(df$chrom) dropMask <- reduce( map( seq_len(nrow(parsed)), @@ -3398,9 +3459,10 @@ effectiveN <- function(nCase, nControl) { # Steps (in order; each contributes a count to audit): # - coerceNumeric: cast signed columns to numeric (catches stray "0.5" # strings). NA-introducing coercions are counted. -# - normalizeChr: strip "chr"/"ch" prefix, uppercase X/Y/MT, map -# 23->X, 24->Y, M->MT. Optional dropNonstandardChr removes rows -# whose CHR is outside 1..22, X, Y, MT after normalization. +# - normalizeChr: spell chromosomes in UCSC style (withChrPrefix(): +# 23->chrX, 24->chrY, M/MT->chrM). Optional dropNonstandardChr +# removes rows whose chromosome is outside chr1..chr22, chrX, chrY, +# chrM after normalization. # - dropMissData: drop rows with NA in any vital column (chrom, pos, # A1, A2, and at least one of Z / BETA). # - dropPOutOfRange: drop rows where P < 0 or P > 1 (corrupt p-values). @@ -3464,16 +3526,12 @@ effectiveN <- function(nCase, nControl) { if (!normalizeChr || !is_in("chrom", colnames(df))) { return(list(df = df, audit = list())) } - chr <- as.character(df$chrom) |> - str_remove(regex("^chr", ignore_case = TRUE)) |> - str_remove(regex("^ch", ignore_case = TRUE)) |> - str_to_upper() |> - canonChromLabel() + chr <- withChrPrefix(df$chrom) normalized <- mutate(df, chrom = chr) if (!dropNonstandardChr) { return(list(df = normalized, audit = list())) } - standardChrs <- c(as.character(seq_len(22)), "X", "Y", "MT") + standardChrs <- str_c("chr", c(as.character(seq_len(22)), "X", "Y", "M")) kept <- filter(normalized, is_in(chr, standardChrs)) list( df = kept, @@ -3632,7 +3690,7 @@ effectiveN <- function(nCase, nControl) { # filtered df, outlier count, and the full per-variant diagnostics table # (the data.frame returned by ldMismatchQc(), prepended with a # variant_id column for downstream joins). Callers record `diagnostics` -# in the entry's qcInfo audit so the per-variant detail is available +# in the entry's QC audit so the per-variant detail is available # for plotting / postprocessing instead of just the outlier count. # Panel LD for an entry's variants, via the shared LD-from-sketch helper (tuple # match with chr-prefix tolerance, strand-ambiguous variants kept), with the @@ -3938,12 +3996,13 @@ effectiveN <- function(nCase, nControl) { # Internal: per-entry pipeline. Returns the cleaned GRanges and an audit list. # --- .runEntrySummaryStatsQc: RAISS imputation step helpers ---------------- -# Panel/dosage window indices for the entry, scoped per chromosome. -.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. +# Panel/dosage window indices for the entry, scoped per chromosome. `clamp` +# (see .ssqcRaissBounds) is the stretch of a chromosome the entry may impute +# into when other rows of its study share that chromosome; the flank stops at +# it. +.qcRaissWindowIdx <- function(df, ldReference, flank, clamp = NULL) { bounds <- tibble( - chrom = canonChrom(as.character(df$chrom)), + chrom = as.character(df$chrom), pos = as.integer(df$pos) ) |> group_by(.data$chrom) |> @@ -3951,7 +4010,8 @@ effectiveN <- function(nCase, nControl) { lo = min(.data$pos, na.rm = TRUE) - flank, hi = max(.data$pos, na.rm = TRUE) + flank, .groups = "drop" - ) + ) |> + .qcRaissClampBounds(clamp) # 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. @@ -3966,6 +4026,20 @@ effectiveN <- function(nCase, nControl) { pull("idx") } +# Narrow the flanked window to the entry's own stretch of the chromosome. +# @noRd +.qcRaissClampBounds <- function(bounds, clamp) { + if (is.null(clamp)) { + return(bounds) + } + on <- bounds$chrom == as.character(seqnames(clamp)) + mutate( + bounds, + lo = if_else(on, pmax(.data$lo, start(clamp)), .data$lo), + hi = if_else(on, pmin(.data$hi, end(clamp)), .data$hi) + ) +} + # Assemble refPanel, knownZ table, and scaled dosage for the window. # The sumstats side of the RAISS inputs: the required columns as a plain # frame, plus whichever of N / BETA / SE the caller carries, sorted by position @@ -4244,7 +4318,7 @@ effectiveN <- function(nCase, nControl) { .qcRaissImpute <- function(df, ldReference, opts, lbl) { imputeBefore <- nrow(df) flank <- as.integer(opts$raissParam$flank) - windowIdx <- .qcRaissWindowIdx(df, ldReference, flank) + windowIdx <- .qcRaissWindowIdx(df, ldReference, flank, opts$raissBounds) if (length(windowIdx) == 0L) { .qcEmit( lbl, @@ -5258,43 +5332,143 @@ effectiveN <- function(nCase, nControl) { # options; the per-entry fields are derived here rather than carried over from # the previous entry. # @noRd -.ssqcRunEntry <- function(i, sumstats, opts, ldReference, isQtl) { +.ssqcRunEntry <- function(i, sumstats, opts, refs, keys, isQtl, bounds) { .runEntrySummaryStatsQc( gr = .collectionEntry(sumstats, i), - ldReference = ldReference, - opts = .ssqcEntryOpts(opts, sumstats, i), + ldReference = .ldRefForKey(keys[[i]], refs), + opts = list_assign( + .ssqcEntryOpts(opts, sumstats, i), + raissBounds = bounds[[i]] + ), entryLabel = .ssqcEntryLabel(sumstats, i, isQtl) ) } -# Run the per-entry QC pipeline across all entries. +# The stretch of its chromosome each row may impute into, or NULL for a row +# with no window of its own that shares its chromosome with no other row of +# its tuple. A study split into LD blocks is several rows on one chromosome, +# and RAISS widening one row's window by `flank` would impute its neighbours' +# variants -- a second, imputed copy of a variant the next row observes. So +# each row keeps to its own window: the `region` it was given, which bounds it +# whether or not its neighbours were loaded, else the midpoints between its +# span and its neighbours'. Without a flank a row's window is its own +# variants' span, which needs no bound. +# @noRd +.ssqcRaissBounds <- function(sumstats, opts) { + n <- nrow(sumstats) + if (!isTRUE(opts$impute) || as.integer(opts$raissParam$flank) <= 0L) { + return(vector("list", n)) + } + chrom <- map_chr(as.list(sumstats), .rtlElementSeqname) + map( + seq_len(n), + .ssqcRowBounds, + group = str_c(.ssqcTupleKey(sumstats), chrom, sep = "\r"), + spans = range(sumstats), + blocks = .ssqcGivenBlocks(sumstats) + ) +} + +# Each row's given window, or NULL where it has none: a computed window is +# only the span the midpoints are taken from. +# @noRd +.ssqcGivenBlocks <- function(sumstats) { + regions <- .rowRegions(sumstats) + map(seq_len(nrow(sumstats)), .ssqcGivenBlockAt, regions = regions) +} + +# @noRd +.ssqcGivenBlockAt <- function(i, regions) { + if (regions$regionGiven[[i]]) regions$region[i] else NULL +} + +# The rows of one tuple: a GWAS study, or a QTL (study, context, trait). +# @noRd +.ssqcTupleKey <- function(sumstats) { + cols <- intersect( + c("study", "context", "trait"), + .tupleColumnNames(sumstats) + ) + exec(str_c, !!!map(cols, .ssqcKeyPart, sumstats = sumstats), sep = "\r") +} + +# @noRd +.ssqcKeyPart <- function(col, sumstats) { + as.character(.tupleColumn(sumstats, col)) +} + +# @noRd +.ssqcRowBounds <- function(i, group, spans, blocks) { + if (!is.null(blocks[[i]])) { + return(blocks[[i]]) + } + if (is.na(group[[i]])) { + return(NULL) + } + sibs <- setdiff(which(group == group[[i]]), i) + if (length(sibs) == 0L) { + return(NULL) + } + .ssqcMidpointBounds(spans[[i]], unlist(spans[sibs], use.names = FALSE)) +} + +# Halfway to the nearest neighbour on each side; a neighbour overlapping the +# row leaves it only its own span. +# @noRd +.ssqcMidpointBounds <- function(own, sib) { + s <- start(own) + e <- end(own) + if (any(start(sib) <= e & end(sib) >= s)) { + return(own) + } + below <- end(sib)[end(sib) < s] + above <- start(sib)[start(sib) > e] + GenomicRanges::GRanges( + seqnames(own), + IRanges::IRanges( + if (length(below) == 0L) 1L else (max(below) + s) %/% 2L + 1L, + if (length(above) == 0L) { + .Machine$integer.max + } else { + (e + min(above)) %/% 2L + } + ) + ) +} + +# Run the per-entry QC pipeline across all entries, each against its own +# row's LD reference. .ssqcRunEntries <- function(sumstats, opts) { isQtl <- methods::is(sumstats, "QtlSumStats") - # Panel filter, once for the shared LD reference and BEFORE any entry is + # Panel filter, once per distinct 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. - ldReference <- .ssqcPrunePanel( + pruned <- map( ldReference(sumstats), - .panelCutoffs(opts$panelFilterParam), - "summaryStatsQc" + .ssqcPrunePanel, + cutoffs = .panelCutoffs(opts$panelFilterParam), + label = "summaryStatsQc" ) - refGenome <- unique(unname(GenomeInfoDb::genome(sumstats))) + keys <- .ldRefKeys(sumstats) results <- map( seq_len(nrow(sumstats)), .ssqcRunEntry, sumstats = sumstats, opts = opts, - ldReference = ldReference, - isQtl = isQtl + refs = pruned, + keys = keys, + isQtl = isQtl, + bounds = .ssqcRaissBounds(sumstats, opts) ) list( newEntries = map(results, "gr"), entryAudits = map(results, "audit"), - ldReference = ldReference + ldReferences = pruned, + keys = keys ) } -# One screen metric's cutoff as qcInfo echoes it. The bundle leaves an unset +# One screen metric's cutoff as qcOptions echoes it. The bundle leaves an unset # metric absent; the echoed record has always spelled "off" as 0, and readers # like qcDiagnostics() index these four names, so the output shape is kept # even though the input is now one argument. @@ -5303,9 +5477,8 @@ effectiveN <- function(nCase, nControl) { signalScreenParam[[metric]] %||% 0 } -# Assemble the qcInfo record (echoed options + per-entry audits). -.ssqcBuildQcInfo <- function( - entryAudits, +# Assemble the qcOptions record: the options QC ran with, echoed. +.ssqcBuildQcOptions <- function( sumstatsFilterParam, panelFilterParam, signalScreenParam, @@ -5348,60 +5521,110 @@ effectiveN <- function(nCase, nControl) { 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, 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))), - ldReference = newLdReference, - varY = as.numeric(sumstats$varY), - nCase = if (is_in("nCase", cols)) { - as.numeric(sumstats$nCase) - } else { - NULL - }, - nControl = if (is_in("nControl", cols)) { - as.numeric(sumstats$nControl) - } else { - NULL - }, - nSample = nSample, - qcInfo = qcInfo, - # 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 (is_in("blockId", cols)) { - as.character(sumstats$blockId) - } else { - NULL - } - ) +# Rebuild the SumStats object with QC'd entries, trimmed sketches (one per +# row, as a list running parallel to `newEntries`), the qcOptions record and +# each row's audit (the qcAudit column). Every column the constructor does +# not rebuild itself is carried across as it was. So is each row's analysis +# window: QC changes the variants, not where the window is -- the one given, +# or the span the row was first built with -- and the span of what is left +# is range(x). +.ssqcRebuild <- function( + sumstats, + newEntries, + newLdReference, + qcOptions, + audits +) { + rebuilt <- if (methods::is(sumstats, "GwasSumStats")) { + .ssqcRebuildGwas(sumstats, newEntries, newLdReference, qcOptions) } else { - QtlSumStats( - studyName = as.character(sumstats$study), - context = as.character(sumstats$context), - trait = as.character(sumstats$trait), - entry = newEntries, - genome = unique(unname(GenomeInfoDb::genome(sumstats))), - ldReference = newLdReference, - varY = as.numeric(sumstats$varY), - nSample = nSample, - qcInfo = qcInfo - ) + .ssqcRebuildQtl(sumstats, newEntries, newLdReference, qcOptions) + } + audited <- `$<-`(rebuilt, "qcAudit", S4Vectors::SimpleList(audits)) + .withRegionColumns(audited, .rowRegions(sumstats)) +} + +# @noRd +.ssqcRebuildQtl <- function(sumstats, newEntries, newLdReference, qcOptions) { + QtlSumStats( + studyName = as.character(sumstats$study), + context = as.character(sumstats$context), + trait = as.character(sumstats$trait), + entry = newEntries, + genome = unique(unname(GenomeInfoDb::genome(sumstats))), + ldReference = newLdReference, + varY = as.numeric(sumstats$varY), + nSample = .ssqcNumericColumn(sumstats, "nSample"), + qcOptions = qcOptions, + traitPos = .ssqcColumnOrNull(sumstats, "traitPos"), + extraCols = .ssqcExtraCols(sumstats, .SSQC_QTL_COLUMNS) + ) +} + +# @noRd +.ssqcRebuildGwas <- function(sumstats, newEntries, newLdReference, qcOptions) { + GwasSumStats( + studyName = as.character(sumstats$study), + entry = newEntries, + genome = unique(unname(GenomeInfoDb::genome(sumstats))), + ldReference = newLdReference, + varY = as.numeric(sumstats$varY), + nCase = .ssqcNumericColumn(sumstats, "nCase"), + nControl = .ssqcNumericColumn(sumstats, "nControl"), + nSample = .ssqcNumericColumn(sumstats, "nSample"), + qcOptions = qcOptions, + # 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 = .ssqcColumnOrNull(sumstats, "blockId"), + extraCols = .ssqcExtraCols(sumstats, .SSQC_GWAS_COLUMNS) + ) +} + +# The columns each constructor builds from its own arguments. Anything else a +# collection carries -- an `extraCols` column -- goes back in through +# `extraCols`. +# @noRd +.SSQC_SHARED_COLUMNS <- c( + "study", + "varY", + "nSample", + "ldReference", + "region", + "regionGiven", + "qcAudit" +) + +# @noRd +.SSQC_QTL_COLUMNS <- c(.SSQC_SHARED_COLUMNS, "context", "trait", "traitPos") + +# @noRd +.SSQC_GWAS_COLUMNS <- c(.SSQC_SHARED_COLUMNS, "nCase", "nControl", "blockId") + +# @noRd +.ssqcExtraCols <- function(sumstats, known) { + extra <- setdiff(.tupleColumnNames(sumstats), known) + set_names(map(extra, .tupleColumn, x = sumstats), extra) +} + +# @noRd +.ssqcColumnOrNull <- function(sumstats, nm) { + if (!is_in(nm, .tupleColumnNames(sumstats))) { + return(NULL) + } + .tupleColumn(sumstats, nm) +} + +# @noRd +.ssqcNumericColumn <- function(sumstats, nm) { + if (!is_in(nm, .tupleColumnNames(sumstats))) { + return(NULL) } + as.numeric(.tupleColumn(sumstats, nm)) } #' Run QC on a SumStats Collection @@ -5418,10 +5641,12 @@ effectiveN <- function(nCase, nControl) { #' 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, -#' etc.). Fine-mapping and TWAS-weights pipelines reject SumStats inputs where -#' \code{length(qcInfo(x)) == 0L}. +#' The returned collection records the options QC ran with in its +#' \code{qcOptions} slot, and what QC did to each row (variant counts, drop +#' counts at each step, which filters fired, etc.) in its \code{qcAudit} +#' column, read as a table with \code{\link{qcInfo}}. Fine-mapping and +#' TWAS-weights pipelines reject SumStats inputs where +#' \code{length(qcOptions(x)) == 0L}. #' #' Column-availability error contract: a non-zero \code{infoCutoff} requires #' every entry to carry an \code{INFO} column, and a non-zero \code{nCutoff} @@ -5435,8 +5660,8 @@ effectiveN <- function(nCase, nControl) { #' \code{\link{twasWeightsPipeline}} measure them on the RSS path, so one #' number means the same thing wherever it is set. MAC is converted to a MAF #' equivalent and the stricter of the two applies, matching -#' \code{\link{QtlDataset}}. Defaults (\code{0}, \code{0}, \code{1}) filter -#' nothing. +#' \code{\link{GenotypeFilterParam}}. Defaults (\code{0}, \code{0}, +#' \code{1}) filter nothing. #' #' The panel is filtered once, before any entry is harmonized, so a variant #' the panel cannot support is absent from the LD used by kriging, @@ -5473,8 +5698,7 @@ effectiveN <- function(nCase, nControl) { #' lives here rather than being split into two that could disagree. #' @param keepVariants Optional character vector of variant IDs (SNP column) to #' retain prior to harmonization. -#' @param skipRegion Optional character vector of \code{"chr:start-end"} -#' strings, or a \code{GRanges}, of regions to drop. +#' @param skipRegion Optional \code{GRanges} of regions to drop. #' @param signalScreenParam Whether to skip an entry before fitting it, #' built with #' \code{\link{SignalScreenParam}} --- the same bundle @@ -5504,8 +5728,9 @@ effectiveN <- function(nCase, nControl) { #' overridden and the override is logged. Inputs with no counts (quantitative #' traits) are unchanged. The escape hatch \code{effectiveN = FALSE} restores #' the raw \code{N} column (or, when there is no \code{N}, the raw total -#' \code{nCase + nControl}) with no override. \code{qcInfo$options$effectiveN} -#' records the setting and each entry's \code{nSource} is one of +#' \code{nCase + nControl}) with no override. +#' \code{qcOptions(x)$options$effectiveN} records the setting and each +#' row's \code{nSource} (a \code{\link{qcInfo}} column) is one of #' \code{"effective"}, \code{"column"}, \code{"total"}, or \code{NA}. #' @param impute Logical (length 1). Run RAISS imputation against the #' \code{ldReference}'s genotype panel as the last QC step, adding z-scores @@ -5517,7 +5742,10 @@ effectiveN <- function(nCase, nControl) { #' RAISS imputation scopes its reference panel to the analysis-region window #' (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. +#' base pairs on each side to retain LD context for edge variants, though +#' never into the stretch of another row of the same study, nor past a +#' block range that was given: a study split into LD blocks imputes each +#' block once, in its own row. #' #' \code{mafCutoff}, \code{macCutoff} and \code{imissCutoff} bound which #' panel variants RAISS will attempt to impute. Without them every rare @@ -5547,8 +5775,8 @@ effectiveN <- function(nCase, nControl) { #' \code{dropZeroEffect} and \code{dropNonpositiveSe}. Applied before any #' 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. +#' @return A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries, +#' \code{qcOptions} filled and each row's QC audit attached. #' @examples #' data(gwasSumStatsS4Example) #' summaryStatsQc(gwasSumStatsS4Example) @@ -5628,8 +5856,7 @@ summaryStatsQc <- function( # The QC record and the rebuilt object around the filtered entries. # @noRd .ssqcAssemble <- function(sumstats, res, opts, signalScreenParam) { - qcInfo <- .ssqcBuildQcInfo( - res$entryAudits, + qcOptions <- .ssqcBuildQcOptions( sumstatsFilterParam = opts$sumstatsFilterParam, panelFilterParam = opts$panelFilterParam, signalScreenParam = signalScreenParam, @@ -5639,10 +5866,23 @@ summaryStatsQc <- function( 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. - newLdReference <- .subsetLdRefToIds(res$ldReference, res$newEntries) - .ssqcRebuild(sumstats, res$newEntries, newLdReference, qcInfo) + # From the PRUNED panels, not the input's: narrowing an original again + # would hand back a sketch the panel filter never reached. Each is cut to + # the variants of the rows that use it. + trimmed <- imap( + res$ldReferences, + .ssqcTrimToRows, + entries = res$newEntries, + keys = res$keys + ) + perRow <- map(res$keys, .ldRefForKey, refs = trimmed) + .ssqcRebuild(sumstats, res$newEntries, perRow, qcOptions, res$entryAudits) +} + +# One LD reference cut to exactly the variants of the rows keyed to it. +# @noRd +.ssqcTrimToRows <- function(ldReference, key, entries, keys) { + .subsetLdRefToIds(ldReference, entries[is_in(keys, key)]) } # ---- slidingWindowLoop callbacks (distance mode) ------------------------ @@ -5743,12 +5983,15 @@ summaryStatsQc <- function( if (df$p_value[i] > 1e-4) { return(TRUE) } - if (length(highCorrCols) == 0) { + # A CS's own column -- cs_corr_ in extractCsInfo()'s layout -- holds its + # self-correlation of 1, which says nothing about the other sets. + otherCols <- setdiff(highCorrCols, str_c("cs_corr_", i)) + if (length(otherCols) == 0) { return(FALSE) } rowVals <- df |> filter(row_number() == i) |> - select(all_of(highCorrCols)) + select(all_of(otherCols)) any(rowVals == 1) } @@ -5770,10 +6013,10 @@ summaryStatsQc <- function( is.na(df[[col]]) } -# One GRanges entry's canonical chromosome vector. +# One GRanges entry's chromosome vector. # @noRd .entryChrom <- function(gr) { - canonChrom(as.character(GenomicRanges::seqnames(gr))) + as.character(GenomicRanges::seqnames(gr)) } # One GRanges entry's integer start positions. diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 70e71808..6b370a4c 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -83,10 +83,11 @@ glue("{side} ({str_flatten(shown, ', ')})") } -# One collection ELEMENT, whichever shape `x` has. On a RangedTupleList the -# elements are the container itself; the DFrame-backed collections still keep -# them in an `entry` column. Both shapes coexist until every collection has -# migrated, so polymorphic call sites go through here. +# One row's payload, whichever collection `x` is -- what its constructor +# takes as `entry`: for TWAS weights and fine-mapping results, the row parts +# rebuilt from its element and the collection's mcols, where the fits sit; +# for the summary-statistics collections, the element itself. A caller +# taking either weight source reads its rows through here. # @noRd .collectionEntry <- function(x, i) { if (methods::is(x, "TwasWeights")) { @@ -98,11 +99,11 @@ x[[i]] } -# ALL elements as a plain list, whichever shape `x` has. +# Every row's payload (.collectionEntry()) as a plain list. # @noRd .collectionEntries <- function(x) { - # TwasWeights entries are derived views, so they have to be rebuilt one by - # one rather than read off as elements (which are bare GRanges). + # Weight and fine-mapping rows are rebuilt one by one: their elements + # alone are bare GRanges, without the fits. if ( methods::is(x, "TwasWeights") || methods::is(x, "FineMappingResultBase") @@ -150,7 +151,7 @@ return(1L) } msg <- glue( - "{cls} has {nrow(x)} entries. Pass `study`, `context`, ", + "{cls} has {nrow(x)} entries. Pass `studyName`, `context`, ", "`trait`, and `method` to select one." ) abort(msg) @@ -185,50 +186,102 @@ } # Internal: resolve a (study, method, blockId) tuple to a single row -# index of a GwasFineMappingResult collection. `region` may be NULL when -# the (study, method) pair maps to a single row; otherwise it disambiguates -# among per-block rows of a genome-wide collection. +# index of a GwasFineMappingResult collection. `blockId` may be NULL when the +# (study, method) pair maps to a single row; otherwise it names one of a +# genome-wide collection's per-block rows. +# @noRd #' @importFrom checkmate assertVector -.tupleSelectRowGwasFmr <- function(x, studyName, method, region = NULL) { +.tupleSelectRowGwasFmr <- function( + x, + studyName = NULL, + method = NULL, + blockId = NULL +) { if (nrow(x) == 0L) { abort("GwasFineMappingResult has no rows.") } - anyUnset <- missing(studyName) || - is.null(studyName) || - missing(method) || - is.null(method) - if (anyUnset) { + if (is.null(studyName) || is.null(method)) { if (nrow(x) == 1L) { return(1L) } msg <- glue( - "GwasFineMappingResult has {nrow(x)} entries. Pass `study` ", + "GwasFineMappingResult has {nrow(x)} entries. Pass `studyName` ", "and `method` to select one." ) abort(msg) } assertVector(studyName, len = 1L) assertVector(method, len = 1L) - assertVector(region, len = 1L, null.ok = TRUE) - .tupleMatchGwas(x, studyName, method, region) + assertVector(blockId, len = 1L, null.ok = TRUE) + .tupleMatchGwas(x, studyName, method, blockId) +} + +# Internal: every row of one (study, method) fit of a GwasFineMappingResult +# -- one per LD block -- or the block `blockId` names. `study` and `method` +# may be left NULL only while they still match a single (study, method) +# pair; a selection spanning several fits is refused rather than returned as +# if it were one. +# @noRd +.tupleSelectRowsGwasFmr <- function(x, studyName, method, blockId = NULL) { + if (nrow(x) == 0L) { + abort("GwasFineMappingResult has no rows.") + } + assertString(studyName, null.ok = TRUE) + assertString(method, null.ok = TRUE) + assertString(blockId, null.ok = TRUE) + idx <- .matchTupleRows( + x, + compact(list(study = studyName, method = method, blockId = blockId)) + ) + if (length(idx) == 0L) { + abort(glue( + "No entry for ", + "({.tupleGwasSelectionLabel(studyName, method, blockId)})." + )) + } + fits <- unique(str_c( + .fmrIdentityColumn(x, "study")[idx], + .fmrIdentityColumn(x, "method")[idx], + sep = "/" + )) + if (length(fits) > 1L) { + abort(glue( + "GwasFineMappingResult holds {length(fits)} (study, method) fits ", + "matching the selection ({str_flatten(fits, ', ')}); pass ", + "`studyName` and `method` to select one." + )) + } + idx +} + +# The selectors as they appear in a no-match message; an unset study or +# method matched anything. +# @noRd +.tupleGwasSelectionLabel <- function(studyName, method, blockId) { + parts <- c( + study = studyName %||% "", + method = method %||% "", + blockId = blockId + ) + str_flatten(str_c(names(parts), "='", parts, "'"), ", ") } # Resolve a (study, method[, blockId]) tuple to a single row index. # @noRd -.tupleMatchGwas <- function(x, studyName, method, region) { +.tupleMatchGwas <- function(x, studyName, method, blockId) { keys <- c( list(study = studyName, method = method), - compact(list(blockId = region)) + compact(list(blockId = blockId)) ) idx <- .matchTupleRows(x, keys) if (length(idx) == 0L) { - regionPart <- if (is.null(region)) { + blockPart <- if (is.null(blockId)) { "" } else { - glue(", region='{region}'") + glue(", blockId='{blockId}'") } msg <- glue( - "No entry for (study='{studyName}', method='{method}'{regionPart})." + "No entry for (study='{studyName}', method='{method}'{blockPart})." ) abort(msg) } @@ -238,17 +291,17 @@ idx[[1L]] } -# Multiple (study, method) rows matched: report the disambiguating regions. +# Multiple (study, method) rows matched: report the blocks to choose from. # @noRd .tupleGwasAmbiguous <- function(x, studyName, method, idx) { - regions <- str_flatten( + blocks <- str_flatten( shQuote(as.character(x$blockId[idx])), ", " ) msg <- glue( "GwasFineMappingResult has {length(idx)} rows matching ", - "(study='{studyName}', method='{method}'); pass `region` to ", - "disambiguate (available: {regions})." + "(study='{studyName}', method='{method}'); pass `blockId` to ", + "disambiguate (available: {blocks})." ) abort(msg) } @@ -257,23 +310,23 @@ # given selectors. NULL selectors, and selectors naming a column the # collection lacks, are ignored -- QTL rows carry study/context/trait/method, # GWAS rows carry study/method/blockId -- so the same call works on either. -# `region` matches the `blockId` column. Returns all rows when nothing -# constrains. Unlike the single-row selectors above this never errors on -# ambiguity; it is the aggregate counterpart used by topLoci(). +# Returns all rows when nothing constrains. Unlike the single-row selectors +# above this never errors on ambiguity; it is the aggregate counterpart used +# by topLoci(). .fmrRowsMatching <- function( x, studyName = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) { supplied <- compact(list( study = studyName, context = context, trait = trait, method = method, - blockId = region + blockId = blockId )) keys <- supplied[is_in(names(supplied), .tupleColumnNames(x))] if (length(keys) == 0L) { @@ -332,23 +385,29 @@ # it on demand, and that is what callers wanting current content should use. # # Spec 4.4 removed a stored column on the grounds that it "would quietly go -# stale" under subsetRegion(). That argument holds for a SPAN, which is +# stale" under subsetting. That argument holds for a SPAN, which is # current state and must track subsetting; it does not hold for a WINDOW, # which is provenance -- subsetting a fit's variants does not retroactively # change which interval was analysed. # # Falls back to the derived span for collections built before the column # existed (older saved objects, hand-built collections), so the accessor never -# returns nothing where it used to return a range. +# returns nothing where it used to return a range. So does a row a combine +# padded with a placeholder (.naLikeColumn()), having no window of its own. # @noRd .getRegionColumn <- function(x) { if (nrow(x) == 0L) { return(GenomicRanges::GRanges()) } - if (is_in("region", .tupleColumnNames(x))) { - return(.tupleColumn(x, "region")) + if (!is_in("region", .tupleColumnNames(x))) { + return(unlist(range(x), use.names = FALSE)) } - unlist(range(x), use.names = FALSE) + stored <- .tupleColumn(x, "region") + padded <- width(stored) == 0L + if (!any(padded)) { + return(stored) + } + .pickRegions(!padded, stored, .rowSpanRanges(x)) } # Internal: append the optional `blockId` provenance column (no-op when NULL). @@ -363,7 +422,7 @@ } if (length(blockId) != n) { msg <- glue( - "`blockId` must have the same length as `study` ", + "`blockId` must have the same length as `studyName` ", "(got {length(blockId)} vs {n})." ) abort(msg) @@ -371,19 +430,15 @@ c(cols, list(blockId = as.character(blockId))) } -# Internal: normalize a caller-supplied window into the single GRanges the -# `region` column stores, or NULL when there is none. Accepts whatever the -# pipeline's `region` argument accepts (a "chr:start-end" string or a -# GRanges); a multi-range window (jointRegions) is recorded as its overall -# span, which is the interval the fit covered. +# Internal: normalize a caller-supplied window -- a GRanges, as the +# pipeline's `region` is -- into the single range the `region` column +# stores, or NULL when there is none. A multi-range window (jointRegions) is +# recorded as its overall span, which is the interval the fit covered. .asAnalysisWindow <- function(region) { if (is.null(region) || length(region) == 0L) { return(NULL) } - gr <- try_fetch(.asGRegion(region), error = function(cnd) NULL) - if (is.null(gr) || length(gr) == 0L) { - return(NULL) - } + gr <- .assertRegionGRanges(region) if (length(gr) == 1L) gr else range(gr)[1L] } @@ -397,9 +452,6 @@ rep(gr, n) } -# Internal: append a validated `region` GRanges to a constructor's column list -# (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. @@ -439,6 +491,10 @@ .appendProvenanceCol(cols, standardized, "standardized", n, as.logical) } +# Internal: append a validated `region` GRanges to a constructor's column list +# (no-op when NULL). Shared by the TwasWeights / FineMappingResultBase +# constructors so the provenance column is added identically everywhere. +# @noRd .appendRegionCol <- function(cols, region, n) { if (is.null(region)) { return(cols) @@ -449,7 +505,7 @@ if (length(region) != n) { abort("`region` must have the same length as `study`.") } - c(cols, list(region = region)) + c(cols, list(region = .ucscRanges(region))) } # Internal: validate the optional `region` GRanges column (one range per row), @@ -470,6 +526,382 @@ character(0) } +# Internal: `n` placeholder ranges, zero-width on "chrUn", for the rows of a +# range column that have no range of their own: an empty element, or the rows +# of a combined part that lacked the column. No real range is zero-width, so +# that is what marks one. +# @noRd +.placeholderRanges <- function(n) { + GenomicRanges::GRanges( + rep("chrUn", n), + IRanges::IRanges(start = rep(1L, n), width = rep(0L, n)) + ) +} + +# Internal: each element's span as one bare range (no seqinfo, strand or +# metadata), or a placeholder for an empty element. An element sits on one +# seqname, so strand aside its span is one range. +# @noRd +.rowSpanRanges <- function(x) { + spans <- range(x, ignore.strand = TRUE) + has <- lengths(spans) > 0L + flat <- unlist(spans, use.names = FALSE) + n <- length(spans) + GenomicRanges::GRanges( + replace(rep("chrUn", n), has, as.character(seqnames(flat))), + IRanges::IRanges( + start = replace(rep(1L, n), has, start(flat)), + end = replace(rep(0L, n), has, end(flat)) + ) + ) +} + +# Internal: per row, the range of `a` where `use` is TRUE, else that of `b`, +# as bare ranges. `a` and `b` have one range per row. +# @noRd +.pickRegions <- function(use, a, b) { + GenomicRanges::GRanges( + if_else(use, as.character(seqnames(a)), as.character(seqnames(b))), + IRanges::IRanges( + start = if_else(use, start(a), start(b)), + end = if_else(use, end(a), end(b)) + ) + ) +} + +# Internal: a window argument -- a `region`, or h2's `ldBlocks` -- as the +# GRanges of the windows it names. Given in an R call, a window is a GRanges, +# 1-based like everything in Bioconductor; a table or a "chr:start-end" +# string is refused rather than read, so no window is misread by one base. A +# file follows its own standard: the path of a BED file is read as BED (see +# .readBedWindows()). +# @noRd +.asRegionRanges <- function(x, what = "`region`") { + if (methods::is(x, "GRanges")) { + return(.ucscRanges(x)) + } + if (!is.character(x) || length(x) != 1L) { + abort(c( + glue( + "{what} must be a GRanges or the path of a BED file ", + "(got {class(x)[[1L]]})." + ), + i = .regionArgHint() + )) + } + if (!file.exists(x)) { + abort(c( + glue("{what}: no file exists at '{x}'."), + i = .regionArgHint() + )) + } + .ucscRanges(.readBedWindows(x, what)) +} + +# Internal: a window argument that takes no file -- a pipeline's `region`, +# or a QtlDataset's -- which must be a GRanges. It comes back in UCSC style, +# so everything it is compared with inside is compared exactly. +# @noRd +.assertRegionGRanges <- function(x, what = "`region`") { + if (!methods::is(x, "GRanges")) { + abort(c( + glue("{what} must be a GRanges (got {class(x)[[1L]]})."), + i = .regionArgHint() + )) + } + .ucscRanges(x) +} + +# Internal: how to give a window in an R call, for the errors refusing a +# window argument of the wrong kind. +# @noRd +.regionArgHint <- function() { + str_c( + "A window given in R is a GRanges, which is 1-based: for example ", + "GenomicRanges::GRanges('chr22:1-100')." + ) +} + +# Internal: the variants of `g` inside the one window `win`. A variant sits at +# its start. +# @noRd +.withinWindow <- function(g, win) { + same <- as.character(seqnames(g)) == as.character(seqnames(win))[[1L]] + g[same & start(g) >= start(win)[[1L]] & start(g) <= end(win)[[1L]]] +} + +# Internal: `gr` as bare ranges, its seqnames and intervals alone. +# @noRd +.bareRanges <- function(gr) { + GenomicRanges::GRanges( + as.character(seqnames(gr)), + IRanges::IRanges(start = start(gr), end = end(gr)) + ) +} + +# Internal: the `region` and `regionGiven` columns of a GWAS collection. A row +# whose block range was given keeps it, and every other row takes the span +# of its own variants. `given` holds one range per row and `has` says which +# of them were given. +# @noRd +.regionColumns <- function(given, has, spans) { + list(region = .pickRegions(has, given, spans), regionGiven = has) +} + +# Internal: refuse a window a fine-mapping result was given that leaves out +# its own row's variants. The check on QTL variants (.checkGwasBlockReach()) +# takes a given window as the block's true boundary, so one that does not hold +# its own variants would send it after a block that is not missing. A variant +# sits at its start, so an indel's width cannot carry it past a window end. +# `pieces` holds each row's variants, and `has` says which rows were given +# `given`. +# @noRd +.refuseUncontainedRegions <- function(given, has, pieces, caller) { + check <- has & lengths(pieces) > 0L + if (!any(check)) { + return(invisible(NULL)) + } + starts <- start(pieces[check]) + chrom <- .rtlElementSeqnames(pieces[check]) + lo <- min(starts) + hi <- max(starts) + inside <- as.character(seqnames(given[check])) == chrom & + start(given[check]) <= lo & + hi <= end(given[check]) + if (all(inside)) { + return(invisible(NULL)) + } + out <- !inside + rows <- glue( + "row {which(check)[out]}: range {as.character(given[check][out])}, ", + "variants at {chrom[out]}:{lo[out]}-{hi[out]}" + ) + abort(c( + glue( + "{caller}: each row's `region` must contain the row's variants, ", + "since it is the window the row was fit over." + ), + set_names(utils::head(rows, 5L), rep("*", min(5L, length(rows)))) + )) +} + +# Internal: each row's analysis window and whether the user gave it, from the +# `region` / `regionGiven` columns of a summary-statistic collection or a +# fine-mapping result. A collection saved before the columns existed has no +# stored window, and neither has a row a combine padded; such a row falls back +# to its span and counts as computed. +# @noRd +.rowRegions <- function(x) { + spans <- .rowSpanRanges(x) + cols <- .tupleColumnNames(x) + if (!is_in("region", cols)) { + return(list(region = spans, regionGiven = rep(FALSE, length(spans)))) + } + stored <- .tupleColumn(x, "region") + has <- width(stored) > 0L + given <- if (is_in("regionGiven", cols)) { + as.logical(.tupleColumn(x, "regionGiven")) + } else { + rep(FALSE, length(spans)) + } + list( + region = .pickRegions(has, stored, spans), + regionGiven = has & !is.na(given) & given + ) +} + +# Internal: row `i`'s analysis window alone (see .rowRegions()), read off its +# own column entry rather than every row's, for per-row lookups. NULL for an +# empty row with no window stored. +# @noRd +.rowRegionAt <- function(x, i) { + if (is_in("region", .tupleColumnNames(x))) { + stored <- .tupleColumn(x, "region")[i] + if (width(stored) > 0L) { + return(.bareRanges(stored)) + } + } + g <- x[[i]] + if (length(g) == 0L) { + return(NULL) + } + .bareRanges(range(g, ignore.strand = TRUE)[1L]) +} + +# Internal: set a GWAS collection's `region` / `regionGiven` columns, for the +# rebuilds that know them better than the constructor can: a QC pass, a union +# of blocks, a fine-mapping run, a file read back. +# @noRd +.withRegionColumns <- function(x, cols) { + md <- mcols(x, use.names = FALSE) + md$region <- cols$region + md$regionGiven <- as.logical(cols$regionGiven) + S4Vectors::`mcols<-`(x, value = md) +} + +# ---- QTL variants past the GWAS blocks -------------------------------------- +# A QTL region is scored against every block of a GWAS study it overlaps, +# merged into one. Its variants outside all of the study's loaded blocks are +# left out of that merge, which is a sign a block it reaches was not loaded. +# Past a block range the caller gave, they do lie in a block that was not +# loaded, so that is an error. Past a range computed from the GWAS variants +# they may only be variants the GWAS lacks, at a chromosome end or untyped, +# so that is a warning, and only for more than one variant in a row. + +# Internal: check `units` -- a named list of variant positions (GRanges), one +# per region the caller scores against `gws`, named as a message should call +# it -- against the block ranges of each GWAS fit in `gws`. Each variant past +# a fit's blocks counts against its nearest block, on the side it falls. +# `caller` and `what` (the units, as a plural noun) word the messages. +# @noRd +.checkGwasBlockReach <- function(units, gws, caller, what) { + if (length(units) == 0L || nrow(gws) == 0L) { + return(invisible(NULL)) + } + blocks <- .gwasBlockTable(gws) + issues <- list_rbind(imap(units, .unitBlockReach, blocks = blocks)) + .reportBlockReach(issues, caller, what) +} + +# Internal: the block ranges of `gws`, one per row with a range, each with +# the GWAS fit it belongs to (its study, and method for a fine-mapping +# result) and a label naming the block. +# @noRd +.gwasBlockTable <- function(gws) { + regions <- .rowRegions(gws) + keep <- width(regions$region) > 0L + region <- regions$region[keep] + chrom <- as.character(seqnames(region)) + ids <- as.character(.tupleColumn(gws, "blockId"))[keep] + key <- str_c(chrom, start(region), end(region), sep = "_") + span <- str_c(chrom, ":", start(region), "-", end(region)) + list( + ranges = .locusRanges(region), + given = regions$regionGiven[keep], + fit = .gwasFitLabels(gws)[keep], + # An id that only spells the range is not repeated beside it. + label = if_else( + is.na(ids) | ids == key, + span, + str_c(ids, " (", span, ")") + ) + ) +} + +# @noRd +.gwasFitLabels <- function(gws) { + study <- str_c("'", as.character(gws$study), "'") + if (!is_in("method", .tupleColumnNames(gws))) { + return(study) + } + str_c(study, " (", as.character(gws$method), ")") +} + +# Internal: one unit's variants past each GWAS fit whose blocks they meet. +# @noRd +.unitBlockReach <- function(variants, unit, blocks) { + v <- .locusRanges(variants) + list_rbind(map( + unique(blocks$fit), + .unitFitReach, + v = v, + unit = unit, + blocks = blocks + )) +} + +# @noRd +#' @importFrom dplyr count +.unitFitReach <- function(fit, v, unit, blocks) { + own <- which(blocks$fit == fit) + r <- blocks$ranges[own] + inside <- .overlapsOnShared(v, r) + if (!any(inside)) { + return(NULL) + } + chroms <- unique(as.character(seqnames(v))[inside]) + out <- v[!inside & is_in(as.character(seqnames(v)), chroms)] + if (length(out) == 0L) { + return(NULL) + } + onChroms <- which(is_in(as.character(seqnames(r)), chroms)) + hit <- own[onChroms][GenomicRanges::nearest( + .onSeqlevels(out, chroms), + .onSeqlevels(r[onChroms], chroms), + ignore.strand = TRUE + )] + count( + tibble( + unit = unit, + fit = fit, + block = blocks$label[hit], + given = blocks$given[hit], + side = if_else( + start(out) < start(blocks$ranges[hit]), + "start", + "end" + ) + ), + .data$unit, + .data$fit, + .data$block, + .data$given, + .data$side + ) +} + +# Internal: abort over variants past a given range, else warn over runs of +# more than one variant past a computed one. +# @noRd +.reportBlockReach <- function(issues, caller, what) { + if (is.null(issues) || nrow(issues) == 0L) { + return(invisible(NULL)) + } + given <- filter(issues, .data$given) + if (nrow(given) > 0L) { + abort(c( + glue( + "{caller}: {what} reach past the LD blocks loaded for a GWAS ", + "study they overlap. Those blocks' ranges were given, so the ", + "variants past them lie in blocks that were not loaded." + ), + .blockReachLines(given), + i = "Load the neighbouring LD blocks of those studies too." + )) + } + computed <- filter(issues, !.data$given, .data$n > 1L) + if (nrow(computed) > 0L) { + warn(c( + glue( + "{caller}: {what} reach past the variants of a GWAS study ", + "they overlap. Those blocks' ranges are the span of the GWAS ", + "variants, so the variants past them may only be ones the ", + "GWAS lacks, or a block may not have been loaded." + ), + .blockReachLines(computed), + i = str_c( + "Give the GWAS its windows as a `region` to have this ", + "checked strictly." + ) + )) + } + invisible(NULL) +} + +# @noRd +.blockReachLines <- function(issues) { + shown <- utils::head(issues, 5L) + lines <- glue( + "{shown$unit}: {shown$n} variant(s) past the {shown$side} of block ", + "{shown$block} of GWAS study {shown$fit}." + ) + more <- nrow(issues) - nrow(shown) + set_names( + c(lines, if (more > 0L) glue("... and {more} more.")), + rep("*", length(lines) + (more > 0L)) + ) +} + # Internal: trait-position provenance. One GRanges per trait carrying the # molecular feature's OWN genomic coordinates (gene/peak range; TSS = start()), # distinct from the fine-mapping `region`. The true trait position cannot be @@ -478,14 +910,13 @@ # and TwasWeights. Mirrors the `region` helpers above; absent for GWAS. # traitPos is optional provenance: always known for a QtlDataset, but only known # for a QtlSumStats when the caller supplied it (it cannot be inferred from -# summary statistics). When the column is absent we return a scalar NA rather -# than an empty GRanges, so traitPosition() reports "no trait position" -# honestly instead of a zero-length range. +# summary statistics). When the column is absent the answer is an empty +# GRanges -- no position, in the type every other answer has. .getTraitPosColumn <- function(x) { if (is_in("traitPos", .tupleColumnNames(x))) { .tupleColumn(x, "traitPos") } else { - NA + GenomicRanges::GRanges() } } @@ -499,7 +930,7 @@ if (length(traitPos) != n) { abort("`traitPos` must have the same length as `study`.") } - c(cols, list(traitPos = traitPos)) + c(cols, list(traitPos = .ucscRanges(traitPos))) } #' @importFrom checkmate checkClass @@ -520,13 +951,16 @@ # Internal: a length-n "unknown" column matching the type of `exemplar`, used # to pad a collection that lacks an optional column before a union row-bind. -# Character -> NA; GRanges -> a 0-width chrUn sentinel range; else NA. +# Character -> NA; GRanges -> placeholder ranges; else NA. .naLikeColumn <- function(exemplar, n) { if (methods::is(exemplar, "GRanges")) { - return(GenomicRanges::GRanges( - rep("chrUn", n), - IRanges::IRanges(start = 1L, width = 0L) - )) + return(.placeholderRanges(n)) + } + if (methods::is(exemplar, "CharacterList")) { + return(IRanges::CharacterList(rep(list(character(0)), n))) + } + if (methods::is(exemplar, "List")) { + return(S4Vectors::SimpleList(rep(list(NULL), n))) } if (is.character(exemplar)) { return(rep(NA_character_, n)) @@ -553,13 +987,14 @@ # 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 `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. +# Preserves the concrete class and rebuilds the LD references: every row keeps +# its own (.ldRefCombine()), unless `ldReference` names one for all of them. +# 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 -# `ldReference` (SumStatsBase's `genome` / `qcInfo`). It is passed in rather +# `ldReference` (SumStatsBase's `genome` / `qcOptions`). 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. @@ -567,13 +1002,15 @@ parts, ldReference = NULL, slots = list(), - genome = NULL + genome = NULL, + fn = ".rbindCollections" ) { parts <- compact(parts) if (length(parts) == 0L) { return(NULL) } - .rbindRangedCollections(parts, ldReference, slots, genome) + dict <- .ldRefCombine(parts, ldReference, fn) + .rbindRangedCollections(parts, dict, slots, genome) } # Internal: aggregate a per-entry accessor across every row of a @@ -600,32 +1037,23 @@ context = NULL, trait = NULL, method = NULL, - region = NULL, + blockId = NULL, perEntry, onSingle = perEntry, viewArgs = list() ) { - single <- .fmrTrySingle( - x, - studyName, - context, - trait, - method, - region, - onSingle, - viewArgs - ) - if (single$done) { - return(single$result) - } - idx <- .fmrRowsMatching( - x, + sel <- list( studyName = studyName, context = context, trait = trait, method = method, - region = region + blockId = blockId ) + single <- .fmrTrySingle(x, sel, onSingle, viewArgs) + if (single$done) { + return(single$result) + } + idx <- exec(.fmrRowsMatching, x, !!!sel) meta <- .fmrRowMetadata(x) if (length(idx) == 0L) { return(.fmrEmptyOrError(single, meta)) @@ -655,38 +1083,18 @@ slice(meta, integer(0)) } -# Attempt the single-entry fast path when any selector is supplied. Returns -# list(done, result) on a successful single-select, else list(done = FALSE, sel) -# carrying the selection error (or NULL when no selector was given). +# Attempt the single-entry fast path when any of `selectors` -- the named row +# selectors -- is supplied. Returns list(done, result) on a successful +# single-select, else list(done = FALSE, sel) carrying the selection error +# (or NULL when no selector was given). # @noRd #' @importFrom rlang try_fetch -.fmrTrySingle <- function( - x, - studyName, - context, - trait, - method, - region, - onSingle, - viewArgs -) { - anySelector <- !is.null(studyName) || - !is.null(context) || - !is.null(trait) || - !is.null(method) || - !is.null(region) - if (!anySelector) { +.fmrTrySingle <- function(x, selectors, onSingle, viewArgs) { + if (length(compact(selectors)) == 0L) { return(list(done = FALSE, sel = NULL)) } sel <- try_fetch( - .fmrSelectEntry( - x, - studyName = studyName, - context = context, - trait = trait, - method = method, - region = region - ), + exec(.fmrSelectEntry, x, !!!selectors), error = function(cnd) cnd ) if (!inherits(sel, "error")) { @@ -742,36 +1150,29 @@ # @noRd .rbindRangedCollections <- function( parts, - ldReference, + dict, slots = list(), genome = NULL ) { cls <- class(parts[[1L]])[[1L]] allCols <- reduce(map(parts, .tupleColumnNames), union) - combined <- set_names(map(allCols, .rbindColumn, parts = parts), allCols) + # Each part keyed its rows into its own references, so the bound rows take + # the keys the combined references were built with. + combined <- list_assign( + set_names(map(allCols, .rbindColumn, parts = parts), allCols), + ldReference = dict$keys + ) md <- exec( S4Vectors::DataFrame, !!!c(combined, list(check.names = FALSE)) ) - elements <- list_flatten(map(parts, as.list)) - # Rebuilding from as.list() merges each part's seqinfo, so a part whose - # elements never had a build set would leave the result carrying both the - # real build and NA. The agreed build is written back explicitly to keep + # Joining the parts merges each part's seqinfo, so a part whose elements + # never had a build set would leave the result carrying both the real + # build and NA. The agreed build is written back explicitly to keep # seqinfo single-valued, which validity requires. - built <- .withGenomeBuild( - GenomicRanges::GRangesList(elements), - !is.null(genome), - genome - ) - grl <- S4Vectors::`mcols<-`(built, value = md) - out <- exec( - methods::new, - cls, - grl, - !!!c(list(ldReference = ldReference), slots) - ) - validObject(out) - out + built <- .withGenomeBuild(.rtlJoinParts(parts), !is.null(genome), genome) + grl <- .rtlNamed(S4Vectors::`mcols<-`(built, value = md)) + exec(methods::new, cls, grl, !!!c(list(ldReference = dict$refs), slots)) } # Concatenate column `cn` across all parts (NA-filling parts that lack it). @@ -810,10 +1211,23 @@ "FineMappingRow", variants = .rtlGatherElements(x, idx), susieFit = md$susieFit[[first]], - cvResult = md$cvResult[[first]] + cvResult = md$cvResult[[first]], + fitVariants = .mdFitVariants(md, idx) ) } +# The variants the fit of rows `idx` was made with, in its order: the first +# row's, as the fit payload is, since rows split from one entry repeat both. +# None for a collection saved before rows recorded them. +# @noRd +.mdFitVariants <- function(md, idx) { + fv <- md$fitVariants + if (is.null(fv)) { + return(character(0)) + } + as.character(fv[[idx[[1L]]]]) +} + # @noRd .fmrPartsVariantIds <- function(parts) { variantIds(.asFmRowPayload(parts)) @@ -867,18 +1281,8 @@ } # @noRd -.fmrRowMarginalEffects <- function(parts, maxPval = NULL) { - tl <- .fmrPartsTopLoci(parts) - if (nrow(tl) == 0L) { - return(.projectMarginalView(tl)) - } - allRows <- .projectMarginalView(tl) - out <- if (is.null(maxPval) || nrow(allRows) == 0L) { - allRows - } else { - filter(allRows, !is.na(.data$p) & .data$p <= maxPval) - } - out +.fmrRowMarginalEffects <- function(parts) { + .projectMarginalView(.fmrPartsTopLoci(parts)) } # @noRd @@ -918,15 +1322,27 @@ } # @noRd +# The fit's own log Bayes factors of the variants the row still holds, each +# found in the fit by id; a row narrowed since the fit loses the columns of +# the variants it dropped, and nothing is rescaled. .fmrRowLbf <- function(parts) { lbf <- .asLbfMatrix(susieFit(parts)) - vids <- .fmrPartsVariantIds(parts) - if (is.null(lbf) || ncol(lbf) != length(vids)) { + if (is.null(lbf)) { return(tibble(variant_id = character(0))) } - wide <- as_tibble(t(as.matrix(lbf)), .name_repair = "minimal") + fitted <- .partsFitIds(parts, lbf) + if (ncol(lbf) != length(fitted)) { + return(tibble(variant_id = character(0))) + } + vids <- .fmrPartsVariantIds(parts) + col <- .fitColumnOf(vids, fitted) + held <- !is.na(col) + wide <- as_tibble( + t(as.matrix(lbf)[, col[held], drop = FALSE]), + .name_repair = "minimal" + ) w <- `names<-`(wide, str_c("lbf_L", seq_len(ncol(wide)))) - bind_cols(tibble(variant_id = as.character(vids)), w) + bind_cols(tibble(variant_id = as.character(vids[held])), w) } # @noRd @@ -984,7 +1400,8 @@ methodFits = md$fits[[first]], cvResult = md$cvResult[[first]], weightStandardized = isTRUE(md$standardized[[first]]), - weightsDataType = md$dataType[[first]] + weightsDataType = md$dataType[[first]], + fitVariants = .mdFitVariants(md, idx) ) } @@ -1014,15 +1431,173 @@ list(variantIds = vids[ok], weights = w[ok]) } -# 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. +# ---- fit coverage ------------------------------------------------------------ +# A row keeps the fit it was built with when its variants are narrowed (to +# those a GWAS also carries, say). The fit, and everything read off it, still +# describes the run on all of its variants, so reading it from a row that +# holds fewer warns. Nothing is rescaled: intersectVariants() is the explicit +# way to restrict a fit. + +# The variants a row's stored fit was made with. # @noRd -.rowParts <- function(x, i) { - if (methods::is(x, "TwasWeights")) { - return(.twrRowParts(x, i)) +.rowFitVariants <- function(parts) { + if (methods::is(parts, "TwasWeightsRow")) { + return(.twRowFitVariants(parts)) + } + .fmRowFitVariants(parts) +} + +# The fit's variables in its own order: the ids the row recorded when it was +# built, else the names the fit's matrix `mat` carries, else -- an unnamed fit +# of a row saved before rows recorded them -- the row's variants as they are. +# @noRd +.partsFitIds <- function(parts, mat = NULL) { + recorded <- .rowFitVariants(parts) + if (length(recorded) > 0L) { + return(recorded) + } + colnames(mat) %||% variantIds(parts) +} + +# How many of `fitted` are gone from `held`. A variant whose alleles +# harmonization swapped is held under another id, so ids that do not match +# exactly are matched allele-aware before they count as gone. +# @noRd +.lostFitVariantCount <- function(fitted, held) { + gone <- fitted[!is_in(fitted, held)] + if (length(gone) == 0L) { + return(0L) } - .fmrRowParts(x, i) + matched <- matchVariants(gone, held, removeStrandAmbiguous = FALSE) + length(gone) - length(unique(matched$idxA)) +} + +# For each of `held`, its column in a fit made on `fitted` (NA when the fit +# has none), matched the same allele-aware way. +# @noRd +.fitColumnOf <- function(held, fitted) { + col <- match(held, fitted) + miss <- which(is.na(col)) + if (length(miss) == 0L) { + return(col) + } + m <- matchVariants(held[miss], fitted, removeStrandAmbiguous = FALSE) + replace(col, miss[m$idxA], m$idxB) +} + +# `parts` unchanged, after warning when its row holds fewer variants than its +# stored fit was made with. +# @noRd +.fitCoverageChecked <- function(parts, caller) { + fitted <- .rowFitVariants(parts) + lost <- .lostFitVariantCount(fitted, variantIds(parts)) + if (lost > 0L) { + warn( + c( + glue( + "{caller}: the stored fit was made with ", + "{length(fitted)} variants, {lost} of which this row no ", + "longer holds." + ), + i = .fitCoverageHint(parts) + ), + class = "pecotmrFitCoverage" + ) + } + parts +} + +# `x` unchanged, after warning once about every row that holds fewer variants +# than its stored fit was made with. +# @noRd +.fitCoverageCheckedRows <- function(x, caller) { + .fitCoverageCheckedAll(list(x), caller) + invisible(x) +} + +# Warn once about the narrowed rows of every collection in `xs`, so a +# pipeline reading the fits of two inputs names all of them in one warning. +# @noRd +.fitCoverageCheckedAll <- function(xs, caller) { + labels <- map(xs, .narrowedRowLabels) + rows <- list_c(labels, ptype = character()) + if (length(rows) == 0L) { + return(invisible(NULL)) + } + warn( + c( + glue( + "{caller}: {length(rows)} row(s) hold fewer variants than ", + "their stored fit was made with." + ), + set_names(utils::head(rows, 5L), rep("*", min(5L, length(rows)))), + i = .fitCoverageHint(xs[[which(lengths(labels) > 0L)[[1L]]]]) + ), + class = "pecotmrFitCoverage" + ) + invisible(NULL) +} + +# The labels of the rows of `x` that hold fewer variants than their stored +# fit was made with. None when `x` records no fit variants, or is not a +# collection at all: an optional input left NULL, or one the caller has yet +# to validate, which this advisory check must not pre-empt. +# @noRd +.narrowedRowLabels <- function(x) { + if (!methods::is(x, "RangedTupleList")) { + return(character(0)) + } + fv <- mcols(x, use.names = FALSE)$fitVariants + if (is.null(fv) || length(x) == 0L) { + return(character(0)) + } + lost <- map_int(seq_along(x), .rowLostFitVariants, x = x, fv = fv) + short <- which(lost > 0L) + if (length(short) == 0L) { + return(character(0)) + } + .pubRowLabels(x, short) +} + +# @noRd +.rowLostFitVariants <- function(i, x, fv) { + .lostFitVariantCount(as.character(fv[[i]]), .grVariantIds(x[[i]])) +} + +# `expr` with its fit-coverage warnings muffled, for a caller that has +# already warned about the rows `expr` reads -- a pipeline that runs itself +# once per study, say. +# @noRd +.muffleFitCoverage <- function(expr) { + withCallingHandlers( + expr, + pecotmrFitCoverage = function(cnd) invokeRestart("muffleWarning") + ) +} + +# What to do about a narrowed row of `x`. Only fine-mapping results have a +# way to restrict their fits, intersectVariants(); weights are refitted. +# @noRd +.fitCoverageHint <- function(x) { + restrict <- if (.isFineMappingPayload(x)) { + str_c( + "intersectVariants() restricts a fit to the variants two results ", + "share; otherwise refit on the variants kept." + ) + } else { + "Refit on the variants kept to have fits that describe them." + } + str_c( + "The fit, and the values read from it, describe the original run on ", + "all of its variants, unchanged. ", + restrict + ) +} + +# @noRd +.isFineMappingPayload <- function(x) { + methods::is(x, "FineMappingRow") || + methods::is(x, "FineMappingResultBase") } # The per-variant weight vector of one row, whichever weight source it came @@ -1107,6 +1682,19 @@ abort(msg) } +# The `entry` elements whose variants lie on more than one chromosome. A +# collection element spans exactly one, so such an entry would be split into +# one row per chromosome, each repeating the entry's identity and payload. +# @noRd +.multiChromosomeEntries <- function(entry) { + which(map_int(entry, .fmRowSeqnameCount) > 1L) +} + +# @noRd +.fmRowSeqnameCount <- function(e) { + n_distinct(as.character(seqnames(variants(e)))) +} + # 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. @@ -1133,7 +1721,8 @@ fits = S4Vectors::SimpleList(map(entry, methodFits)), cvResult = S4Vectors::SimpleList(map(entry, cvResult)), standardized = map_lgl(entry, .twPayloadStandardized), - dataType = S4Vectors::SimpleList(map(entry, weightsDataType)) + dataType = S4Vectors::SimpleList(map(entry, weightsDataType)), + fitVariants = IRanges::CharacterList(map(entry, .twRowFitVariants)) ) } @@ -1141,15 +1730,14 @@ # Combining summary-statistics collections # ----------------------------------------------------------------------------- # A SumStatsBase subclass carries three COLLECTION-level slots -- ldReference, -# genome and qcInfo -- on top of the elements and their mcols, so row-binding +# genome and qcOptions -- 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 # combineQtlSumStats(), so the two cannot drift: # # genome must agree; a mismatch is an error -# 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 +# qcOptions carried from the first part after checking the QC options +# agree; each row's audit is a column, so it binds with the rows # ldReference the panels union, read through the parts' shared GenotypeHandle # # The ldReference rule is the one that matters for correctness. A block-parallel @@ -1185,9 +1773,17 @@ # @noRd .rtlExtraSlots <- function(parts, fn) { own <- setdiff(.rtlOwnSlots(parts[[1L]]), "ldReference") - out <- compact(list( - qcInfo = if (is_in("qcInfo", own)) .ssCombineQcInfo(parts, fn) - )) + # discard(is.null), not compact(): parts no QC has run on merge to an + # empty qcOptions, which is a merged value -- compact() would drop it and + # report the slot as having no merge rule. + out <- discard( + list( + qcOptions = if (is_in("qcOptions", own)) { + .ssCombineQcOptions(parts, fn) + } + ), + is.null + ) unknown <- setdiff(own, names(out)) if (length(unknown) > 0L) { cls <- class(parts[[1L]])[[1L]] @@ -1202,7 +1798,8 @@ # Merge `parts` into one collection, reconciling every collection-level slot. # The single path behind `c()` / `append()` and the four combine*() wrappers. -# A non-NULL `ldReference` overrides the unioned panel. +# Every row keeps its own LD reference; a non-NULL `ldReference` is every +# row's instead. # @noRd .combineTupleCollections <- function(parts, ldReference, fn) { .rtlRequireSameClass(parts, fn) @@ -1212,9 +1809,10 @@ genome <- .rtlCombineGenome(parts, fn) .rbindCollections( parts, - ldReference = ldReference %||% .combineLdRef(parts, fn), + ldReference = ldReference, slots = .rtlExtraSlots(parts, fn), - genome = genome + genome = genome, + fn = fn ) } @@ -1256,14 +1854,12 @@ genomes } -# qcInfo is collection-level EXCEPT `entryAudit`, which qcDiagnostics() -# addresses BY element index -- so the audit concatenates in element order -# while the rest is carried from the first part. Concatenation pads a part -# whose audit is absent or short, because an audit that slipped out of step -# with the elements would report another block's diagnostics. +# qcOptions describes the whole collection, so it is carried from the first +# part once every part is shown to have run the same QC. Each row's audit is +# a column of mcols(), so it binds with the rows it describes. # @noRd -.ssCombineQcInfo <- function(parts, fn) { - populated <- keep(parts, .ssHasQcInfo) +.ssCombineQcOptions <- function(parts, fn) { + populated <- keep(parts, .ssHasQcOptions) if (length(populated) == 0L) { return(list()) } @@ -1271,39 +1867,24 @@ msg <- glue( "{fn}: {length(parts) - length(populated)} of {length(parts)} ", "inputs carry no QC record. Run summaryStatsQc() on every input ", - "before combining, or the combined qcInfo would claim QC that ", - "only some elements went through." + "before combining, or the combined qcOptions would claim QC ", + "that only some elements went through." ) abort(msg) } .ssCheckQcOptions(populated, fn) - list_assign( - qcInfo(populated[[1L]]), - entryAudit = list_flatten(map(parts, .ssEntryAudit)) - ) + qcOptions(populated[[1L]]) } # @noRd -.ssHasQcInfo <- function(x) length(qcInfo(x)) > 0L - -# One part's per-element audit, padded to its element count so positions stay -# aligned with the elements they describe. -# @noRd -.ssEntryAudit <- function(x) { - audit <- qcInfo(x)$entryAudit %||% list() - n <- nrow(x) - if (length(audit) >= n) { - return(as.list(audit)[seq_len(n)]) - } - c(as.list(audit), vector("list", n - length(audit))) -} +.ssHasQcOptions <- function(x) length(qcOptions(x)) > 0L # The QC options must match: a collection stitched from blocks filtered at # different MAF / INFO cutoffs has no single honest answer for "what QC ran", # and every downstream consumer reads that answer off one record. # @noRd .ssCheckQcOptions <- function(parts, fn) { - first <- qcInfo(parts[[1L]])$options + first <- qcOptions(parts[[1L]])$options same <- map_lgl(parts, .ssSameQcOptions, first = first) if (all(same)) { return(invisible(NULL)) @@ -1318,38 +1899,121 @@ # @noRd .ssSameQcOptions <- function(x, first) { - identical(qcInfo(x)$options, first) + identical(qcOptions(x)$options, first) } -# The union of the parts' LD panels. All-NULL stays NULL (an individual-level -# collection has no panel); a mix is an error, because silently keeping the -# panels that exist would leave elements harmonized against nothing. +# The LD references of `parts`, row-bound: each row keeps the reference it +# had, and a reference that is a view of another is stored as that one +# (.ldRefMergeViews()). `override`, when given, is every row's reference +# instead. # @noRd -.combineLdRef <- function(parts, fn) { - sketches <- map(parts, ldReference) - present <- !map_lgl(sketches, is.null) - if (!any(present)) { - return(NULL) +.ldRefCombine <- function(parts, override, fn) { + if (!is.null(override)) { + n <- sum(map_int(parts, length)) + return(.ldRefDict(.ldRefPerTuple(override, n))) } - if (!all(present)) { - msg <- glue( - "{fn}: {sum(!present)} of {length(parts)} inputs carry no ", - "ldReference. Combine collections that all have an LD reference, ", - "or all have none." - ) - abort(msg) + perRow <- list_flatten(map(parts, .rowLdRefs)) + .ldRefMergeViews(.ldRefDict(perRow), fn) +} + +# `dict` with every entry that is a view of another stored as that one, and +# the rows re-keyed to it. Block-parallel pipelines narrow each piece's panel +# to its own block, so binding the pieces back together would otherwise hold +# one panel per block where there is one panel. +# +# Entries are taken widest first, and each joins the first group whose head +# (its widest entry) it is a view of, or heads a new one. An entry so meets +# the widest reference holding it before any narrower one, whatever order the +# rows came in. Groups are numbered by their first row, so `ld1` stays the +# first row's reference. +# @noRd +.ldRefMergeViews <- function(dict, fn) { + refs <- dict$refs + if (length(refs) <= 1L) { + return(dict) + } + grouped <- reduce( + order(map_int(refs, .ldRefNVariants), decreasing = TRUE), + .ldRefAssignGroup, + refs = refs, + .init = list(heads = integer(0), group = integer(length(refs))) + ) + seen <- unique(grouped$group) + group <- match(grouped$group, seen) + merged <- map( + seq_along(seen), + .ldRefGroupRef, + group = group, + heads = grouped$heads[seen], + refs = refs, + fn = fn + ) + keys <- str_c("ld", seq_along(merged)) + list( + refs = set_names(merged, keys), + keys = keys[group[match(dict$keys, names(refs))]] + ) +} + +# `grouped` extended by entry `i`: it joins the first group whose head it is +# a view of, or heads a new group. +# @noRd +#' @importFrom purrr detect_index +.ldRefAssignGroup <- function(grouped, i, refs) { + hit <- detect_index(grouped$heads, .ldRefHeadHolds, i = i, refs = refs) + if (hit == 0L) { + grouped$heads <- c(grouped$heads, i) + hit <- length(grouped$heads) + } + grouped$group[[i]] <- hit + grouped +} + +# @noRd +.ldRefHeadHolds <- function(h, i, refs) { + .ldRefIsViewOf(refs[[i]], refs[[h]]) +} + +# TRUE when reference `x` can be stored as `of`: panels reading the same files +# over the same samples, or an LdMatrix or mixture all of whose variants `of` +# holds, with the same LD. +# @noRd +.ldRefIsViewOf <- function(x, of) { + if (.ldIsPanel(x) && .ldIsPanel(of)) { + return(.ssSameGenotypeSource(x, of)) + } + if (.ldIsMatrixRef(x) && .ldIsMatrixRef(of)) { + return(.ldmCoveredBy(x, of)) } - if (any(map_lgl(sketches, .ldIsMatrixRef))) { - return(.combineLdMatrixRefs(sketches, fn)) + if (.ldIsMixtureRef(x) && .ldIsMixtureRef(of)) { + return(.ldRefVariantsCoveredBy(x, of) && .gmSameMixture(x, of)) } - if (any(map_lgl(sketches, .ldIsMixtureRef))) { - return(.combineMixtureRefs(sketches, fn)) + FALSE +} + +# The one reference group `g` is stored as. Panels from one source union. An +# LdMatrix or mixture cannot be widened -- the LD between variants that +# different members hold is in none of them -- so the group's head, which +# holds every other member, stands for it. +# @noRd +.ldRefGroupRef <- function(g, group, heads, refs, fn) { + members <- unname(refs[group == g]) + if (length(members) == 1L || !.ldIsPanel(members[[1L]])) { + return(refs[[heads[[g]]]]) } - .ssCheckSameSource(sketches, fn) - chromPaths <- .ssUnionChromPaths(sketches, fn) - handles <- map(sketches, .ldRefHandle) + .unionPanelRefs(members, fn) +} + +# One panel standing for `panels`, which read the same files over the same +# 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 +.unionPanelRefs <- function(panels, fn) { + chromPaths <- .ssUnionChromPaths(panels, fn) + handles <- map(panels, .ldRefHandle) if (any(map_lgl(handles, is.null))) { - return(.ssUnionPanels(sketches, chromPaths)) + return(.ssUnionPanels(panels, chromPaths)) } handle <- methods::initialize( handles[[1L]], @@ -1385,7 +2049,7 @@ ) kept <- which(!duplicated(names(rr))) ord <- kept[order( - canonChrom(as.character(seqnames(rr)[kept])), + as.character(seqnames(rr)[kept]), start(rr)[kept] )] md <- S4Vectors::metadata(stacked) @@ -1395,60 +2059,6 @@ 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) { @@ -1512,24 +2122,6 @@ abort(msg) } -# 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(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 references ", - "cannot be unioned." - ) - abort(msg) -} - # @noRd .ssSameGenotypeSource <- function(x, first) { # chromPaths is deliberately NOT compared: two sketches trimmed from the @@ -1563,7 +2155,7 @@ si <- if (nrow(combined) > 0L && keyed) { deduped <- combined[!duplicated(combined$SNP), , drop = FALSE] deduped[ - order(canonChrom(deduped$CHR), as.integer(deduped$BP)), + order(deduped$CHR, as.integer(deduped$BP)), , drop = FALSE ] diff --git a/R/twasWeights.R b/R/twasWeights.R index 6d05440b..4a43c4d2 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -23,11 +23,13 @@ # ============================================================================= # TwasWeights S4 class # ----------------------------------------------------------------------------- -# 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: -# * ldReference GenotypeHandle (NULL for individual-level fits, the -# LD-sketch handle for RSS-derived weights). +# RangedTupleList collection keyed by the identity tuple (study, context, +# trait, method). Each element is one row's variants, with their weights as +# its `weight` mcols column; the fits, cross-validation and scale are columns +# of the collection's own mcols. Class-level slots: +# * ldReference the LD references RSS-derived weights used, each stored +# once; the ldReference mcols column names each row's (NA +# for weights learned from individual-level data). # Constructor + accessors below. The twasWeights pipeline helpers # (learnTwasWeights, CV, ensemble, etc.) follow at the bottom. # ============================================================================= @@ -36,14 +38,16 @@ NULL #' @title TWAS Weights Collection -#' @description S4 collection of TWAS weights keyed by the identity tuple -#' \code{(study, context, trait, method)}. Each entry is a -#' \code{TwasWeightsRow} carrying one method's weights for one -#' trait/context/study. Implements the \code{DFrame}-subclass collection -#' pattern. +#' @description S4 collection of TWAS weights, one row per +#' \code{(study, context, trait, method)}: one method's weights for one +#' trait, context and study. Each element is a row's variants: a +#' \code{GRanges} whose \code{weight} column holds the weights. #' -#' Required columns: \code{study}, \code{context}, \code{trait}, \code{method}, -#' \code{entry}. Each \code{entry} is a \code{TwasWeightsRow}. +#' Required \code{mcols()} columns: the identity tuple \code{study}, +#' \code{context}, \code{trait} and \code{method}, and each row's payload: +#' its stored fits (\code{fits}), \code{cvResult}, \code{standardized} and +#' \code{dataType}. The constructor also records \code{fitVariants}, the +#' variants the weights were fitted on. #' #' Optional columns \code{jointStudies}, \code{jointContexts}, #' \code{jointTraits} appear when the collection contains rows produced by a @@ -52,16 +56,28 @@ 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 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. +#' @slot ldReference A named list of the LD references the weights were +#' derived against, each a genotype panel, a \code{GenotypeMixture} or an +#' \code{LdMatrix}, stored once apiece; the \code{ldReference} column of +#' \code{mcols} names the entry each row used (\code{NA} for weights +#' learned from individual-level data). Used downstream to check that the +#' rows a pipeline combines share an LD reference. +#' @section Narrowed rows: Each row records in its \code{fitVariants} column +#' the ids of the variants its weights were fitted on (none for a row +#' without a fit payload). A row narrowed since keeps its fits as they +#' were, so \code{cvResult()} and \code{methodFits()} warn, with condition +#' class \code{pecotmrFitCoverage}, when a row holds fewer variants than +#' they describe. So do the pipelines that read them: +#' \code{causalInferencePipeline()} when it selects weights by their +#' cross-validation, and \code{ctwasPipeline()} for rows whose SuSiE fit +#' renormalizes their weights. The weights themselves are narrowed with +#' the row and do not warn. #' @export setClass( "TwasWeights", contains = "RangedTupleList", - representation(ldReference = "LdReference_OR_NULL"), + representation(ldReference = "list"), + prototype(ldReference = list()), validity = function(object) .validateTwasWeights(object) ) @@ -100,7 +116,8 @@ setClass( .validateTraitPosColumn(object), .validateRegionColumn(object), .twasValidateJointCols(object, jointCols), - .twasValidateKeyUniqueness(object, jointCols) + .twasValidateKeyUniqueness(object, jointCols), + .ldRefDictProblems(object@ldReference, .ldRefKeys(object)) ) } @@ -131,10 +148,7 @@ setClass( # @noRd .twasValidateKeyUniqueness <- function(object, jointCols) { keyCols <- c("study", "context", "trait", "method", jointCols) - # Extract key columns directly rather than via `object[, keyCols]`: - # column-subsetting preserves the TwasWeights class while dropping the - # required `entry` column, and older S4Vectors revalidates that - # intermediate, spuriously failing with "missing columns: entry". + # Read column by column: `[` takes no column index on a collection. keyTbl <- as_tibble(set_names( map(keyCols, .twasColumn, object = object), keyCols @@ -152,9 +166,8 @@ setClass( # ============================================================================= #' @title Create a TwasWeights Collection Object -#' @description Construct a \code{TwasWeights} DFrame-subclass collection from -#' per-tuple vectors and a list of \code{TwasWeightsRow} payloads (one per -#' tuple). +#' @description Construct a \code{TwasWeights} collection from per-tuple +#' vectors and a list of \code{TwasWeightsRow} payloads (one per tuple). #' @param studyName Character vector of study identifiers. Use the sentinel #' \code{"joint"} for rows produced by a cross-study joint fit. #' @param context Character vector of context labels. Use \code{"joint"} for @@ -171,8 +184,11 @@ setClass( #' shape as \code{jointStudies}. #' @param jointTraits Optional character vector for cross-trait joints. Same #' shape as \code{jointStudies}. -#' @param ldReference An optional genotype panel (see -#' \code{\link{readGenotypes}}), or \code{NULL} for individual-level fits. +#' @param ldReference The LD reference the weights were derived against -- +#' a genotype panel (see \code{\link{readGenotypes}}), a +#' \code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +#' a list with one per row; \code{NULL} for individual-level fits. Each +#' distinct reference is stored once. #' @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. @@ -181,9 +197,12 @@ setClass( #' 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. +#' @param metadata A list of free-form metadata about the collection, +#' as \code{metadata()} holds on any Bioconductor vector. Default +#' \code{list()}. #' @return A \code{TwasWeights} object. #' @examples -#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), +#' twe <- TwasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), #' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), #' weightStandardized = FALSE) #' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "gene1", @@ -203,7 +222,8 @@ TwasWeights <- function( jointTraits = NULL, traitPos = NULL, region = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) { .twasAssertArgs( studyName, @@ -231,7 +251,10 @@ TwasWeights <- function( region, n ) - .rtlNewValidated("TwasWeights", entry, cols, ldReference) + .withMetadata( + .rtlNewValidated("TwasWeights", entry, cols, ldReference), + metadata + ) } # The identity and joint-axis arguments, checked. Mirrors @@ -313,7 +336,7 @@ TwasWeights <- function( length(entry) != n ) { msg <- glue( - "`study`, `context`, `trait`, `method`, and `entry` must all ", + "`studyName`, `context`, `trait`, `method`, and `entry` must all ", "have the same length." ) abort(msg) @@ -349,11 +372,6 @@ TwasWeights <- function( abort(msg) } -#' @rdname genomicRegion -#' @export -setMethod("genomicRegion", "TwasWeights", function(x) .getRegionColumn(x)) - - #' @rdname traitPosition #' @export setMethod("traitPosition", "TwasWeights", function(x) { @@ -374,7 +392,7 @@ setMethod("traitPosition", "TwasWeights", function(x) { #' collection has a single row. #' @return A \code{TwasWeightsRow} object. #' @examples -#' twe <- twasWeightsRow( +#' twe <- TwasWeightsRow( #' variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), #' cvResult = list(rsq = 0.5), weightStandardized = FALSE) #' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", @@ -385,7 +403,13 @@ setMethod("traitPosition", "TwasWeights", function(x) { #' @export setGeneric( "twasWeights", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL + ) { standardGeneric("twasWeights") } ) @@ -395,16 +419,14 @@ setGeneric( setMethod( "twasWeights", "TwasWeights", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { - idx <- .tupleSelectRow( - x, - studyName, - context, - trait, - method, - cls = "TwasWeights" - ) - x[idx] + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL + ) { + x[.twrSelectRowIndex(x, studyName, context, trait, method)] } ) @@ -414,14 +436,10 @@ setMethod( mcols(x[[i]])$weight } -# The row payload a (study, context, trait, method) selector pins. -# -# Read directly rather than via twasWeights(): that accessor returns a -# single-row collection, so routing the per-field accessors through it would -# dispatch straight back into them. +# The row a (study, context, trait, method) selector pins. # @noRd -.twrSelectRowParts <- function(x, studyName, context, trait, method) { - idx <- .tupleSelectRow( +.twrSelectRowIndex <- function(x, studyName, context, trait, method) { + .tupleSelectRow( x, studyName, context, @@ -429,7 +447,19 @@ setMethod( method, cls = "TwasWeights" ) - .twrRowParts(x, idx) +} + +# The row payload that selector pins. +# +# Read directly rather than via twasWeights(): that accessor returns a +# single-row collection, so routing the per-field accessors through it would +# dispatch straight back into them. +# @noRd +.twrSelectRowParts <- function(x, studyName, context, trait, method) { + .twrRowParts( + x, + .twrSelectRowIndex(x, studyName, context, trait, method) + ) } #' @rdname resolveWeights @@ -469,7 +499,7 @@ setMethod( #' this fine-mapping / weight method; \code{NULL} matches all methods. #' @return A numeric vector or matrix of weights. #' @examples -#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), +#' twe <- TwasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), #' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), #' weightStandardized = FALSE) #' weights(twe) @@ -489,7 +519,13 @@ setMethod( ... ) { weights( - .twrSelectRowParts(object, studyName, context, trait, method) + .twrSelectRowParts( + object, + studyName, + context, + trait, + method + ) ) } ) @@ -506,7 +542,8 @@ setMethod( trait = NULL, method = NULL ) { - cvResult(.twrSelectRowParts(x, studyName, context, trait, method)) + parts <- .twrSelectRowParts(x, studyName, context, trait, method) + cvResult(.fitCoverageChecked(parts, "cvResult()")) } ) @@ -522,24 +559,57 @@ setMethod( trait = NULL, method = NULL ) { - methodFits(.twrSelectRowParts(x, studyName, context, trait, method)) + parts <- .twrSelectRowParts(x, studyName, context, trait, method) + methodFits(.fitCoverageChecked(parts, "methodFits()")) + } +) + +# Before rows recorded the variants their weights were fitted on, a +# collection had no `fitVariants` column; a row saved then records the +# variants it holds, and a row with no fit payload records none. The +# inherited update runs either way, for the updates every collection shares. +#' @rdname updateObject-methods +#' @export +setMethod( + "updateObject", + "TwasWeights", + function(object, ..., verbose = FALSE) { + if (isTRUE(verbose)) { + message("updateObject(object = 'TwasWeights')") + } + if (!is_in("fitVariants", .tupleColumnNames(object))) { + held <- map(seq_along(object), .twrBackfillFitVariants, x = object) + object <- `$<-`(object, "fitVariants", IRanges::CharacterList(held)) + } + methods::callNextMethod(object, ..., verbose = verbose) } ) +# @noRd +.twrBackfillFitVariants <- function(i, x) { + md <- mcols(x, use.names = FALSE) + if (length(md$fits[[i]]) == 0L && is.null(md$cvResult[[i]])) { + return(character(0)) + } + .grVariantIds(x[[i]]) +} + #' @rdname weightStandardized #' @export setMethod( "weightStandardized", "TwasWeights", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL + ) { isTRUE( - weightStandardized(.twrSelectRowParts( - x, - studyName, - context, - trait, - method - )) + weightStandardized( + .twrSelectRowParts(x, studyName, context, trait, method) + ) ) } ) @@ -549,14 +619,16 @@ setMethod( setMethod( "weightsDataType", "TwasWeights", - function(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) { - weightsDataType(.twrSelectRowParts( - x, - studyName, - context, - trait, - method - )) + function( + x, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL + ) { + weightsDataType( + .twrSelectRowParts(x, studyName, context, trait, method) + ) } ) @@ -584,7 +656,9 @@ setMethod("studyName", "TwasWeights", function(x) unique(as.character(x$study))) #' @rdname ldReference #' @export -setMethod("ldReference", "TwasWeights", function(x) x@ldReference) +setMethod("ldReference", "TwasWeights", function(x) { + .ldRefsInUse(x) +}) #' @rdname contexts #' @export @@ -604,7 +678,6 @@ setMethod("methodNames", "TwasWeights", function(x) { unique(as.character(x$method)) }) - #' @rdname show-methods #' @export setMethod("show", "TwasWeights", function(object) { @@ -618,15 +691,13 @@ setMethod("show", "TwasWeights", function(object) { .trim = FALSE )) } - ldSrc <- if (is.null(object@ldReference)) { + ldSrc <- .ldRefsLabel( + ldReference(object), "NULL (individual-level fit)" - } else { - .ldRefLabel(object@ldReference) - } + ) cat(glue(" LD reference: {ldSrc}\n", .trim = FALSE)) }) - # ============================================================================= # TwasWeights pipeline helpers (learnTwasWeights + CV + ensemble + # Mvsusie/Mrmash) @@ -691,6 +762,7 @@ setMethod("show", "TwasWeights", function(object) { args = list(max.iter = 100) ), enet = list(fn = "enet_weights", impl = "enetWeights", args = list()), + ridge = list(fn = "ridge_weights", impl = "ridgeWeights", args = list()), lasso = list( fn = "lasso_weights", impl = "lassoWeights", @@ -849,6 +921,7 @@ setMethod("show", "TwasWeights", function(object) { list( lasso = c("lassoWeights", "glmnetWeights", "glmnet::cv.glmnet"), enet = c("enetWeights", "glmnetWeights", "glmnet::cv.glmnet"), + ridge = c("ridgeWeights", "glmnetWeights", "glmnet::cv.glmnet"), scad = c("scadWeights", "ncvregWeights", "ncvreg::cv.ncvreg"), mcp = c("mcpWeights", "ncvregWeights", "ncvreg::cv.ncvreg"), l0learn = c("l0learnWeights", "L0Learn::L0Learn.cvfit"), @@ -884,10 +957,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. 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 +# .prsCsRun(), .sdprRun()), which take the options of penalizedRss() -- +# lassosumRss()'s are a subset -- prsCs() and sdpr() under the same names, so # a genotype reference can be used through its factor without forming the LD -# matrix. +# matrix. Every penalized method's path is .penalizedRssPath(): the penalty +# reaches it as one record its wrapper built, so only the path's own options +# (lambda, thr, maxiter) count as the method's. # @noRd .twasMethodChainsSumstat <- function() { list( @@ -911,7 +986,19 @@ setMethod("show", "TwasWeights", function(object) { lasso = c( "lassosumRssWeights", ".rssShrinkGridWeights", - ".lassosumRssPath" + ".penalizedRssPath" + ), + enet = c( + "enetRssWeights", + ".penalizedRssWeights", + ".rssShrinkGridWeights", + ".penalizedRssPath" + ), + ridge = c( + "ridgeRssWeights", + ".penalizedRssWeights", + ".rssShrinkGridWeights", + ".penalizedRssPath" ), prsCs = c("prsCsWeights", ".prsCsRun"), dprGibbs = c("sdprWeights", ".sdprRun"), @@ -960,6 +1047,8 @@ setMethod("show", "TwasWeights", function(object) { "solverInput", "LDs", "config", + "spec", + "label", "bInit", "vInit", "K" @@ -1007,7 +1096,6 @@ setMethod("show", "TwasWeights", function(object) { (length(fm) == 1L && is.na(fm[[1L]])) || is_in("...", fm) } - # The implementation that runs one method on one input path. # @noRd .twasMethodImplFor <- function(token, inputKind) { @@ -1732,10 +1820,11 @@ setMethod("show", "TwasWeights", function(object) { #' maximum number of variants to use for CV purpose, to save computing time. #' @param variantsToKeep An optional integer to ensure that the listed variants #' are kept in the CV when there is a limit on the maxNumVariants to use. -#' @param numThreads The number of threads to use for parallel processing. If -#' set to -1, the function uses all available cores. If set to 0 or 1, no -#' parallel processing is performed. If set to 2 or more, parallel processing -#' is enabled with that many threads. +#' @param BPPARAM A \code{BiocParallelParam} the folds run on; +#' \code{SerialParam()} (default) runs them one at a time. Each draws from +#' its own random-number stream, seeded by \code{seed}, else by the param's +#' own \code{RNGseed}, else by one draw from the session RNG, so a run +#' gives the same numbers however many workers it has. #' @param verbose Integer controlling verbosity level: 0 = suppress all #' messages, 1 = suppress external package messages (default), 2 = show all #' messages including those from external packages. @@ -1746,11 +1835,9 @@ setMethod("show", "TwasWeights", function(object) { #' for every other method the two behave alike. #' @param seed Integer or \code{NULL}. When supplied, seeds both the #' main-process RNG (fold partitioning, variant sub-sampling) and the -#' parallel fold-fitting RNG via the \code{BiocParallel} \code{RNGseed}, so -#' results are reproducible even under multi-threading. The main-process -#' seed is scoped to the call, so the session RNG is left as it was found. -#' \code{NULL} (default) does not seed at all and uses the historical -#' parallel default. +#' streams the folds draw from (see \code{BPPARAM}). The main-process seed +#' is scoped to the call, so the session RNG is left as it was found. +#' \code{NULL} (default) seeds neither. #' @param fittedModelsCv Optional per-fold fine-mapping fits, as #' \code{method -> fold_ -> fit}, from a \code{fineMappingPipeline()} #' run with \code{cvFolds > 1}. SuSiE-family weight wrappers extract from a @@ -1786,7 +1873,7 @@ setMethod("show", "TwasWeights", function(object) { #' process. #' } #' @importFrom purrr map -#' @importFrom BiocParallel bplapply multicoreWorkers MulticoreParam +#' @importFrom BiocParallel SerialParam #' @importFrom quadprog solve.QP #' @examples #' data(multiTraitData) @@ -1808,7 +1895,7 @@ twasWeightsCv <- function( weightMethods = NULL, maxNumVariants = NULL, variantsToKeep = NULL, - numThreads = 1, + BPPARAM = SerialParam(), verbose = 1, fitRetention = c("none", "slim", "full"), seed = NULL, @@ -1824,7 +1911,7 @@ twasWeightsCv <- function( # .cvSubsampleVariants relies on `ncol(X) <= maxNumVariants` being FALSE # for it. assertNumber(maxNumVariants, lower = 1, null.ok = TRUE) - assertInt(numThreads) + .assertBpparam(BPPARAM) assertCount(verbose) fitRetention <- arg_match(fitRetention) assertInt(seed, null.ok = TRUE) @@ -1836,7 +1923,7 @@ twasWeightsCv <- function( weightMethods = weightMethods, maxNumVariants = maxNumVariants, variantsToKeep = variantsToKeep, - numThreads = numThreads, + BPPARAM = BPPARAM, verbose = verbose, fitRetention = fitRetention, seed = seed, @@ -1939,7 +2026,7 @@ twasWeightsCv <- function( weightMethods, maxNumVariants, variantsToKeep, - numThreads, + BPPARAM, verbose, fitRetention, seed, @@ -1971,7 +2058,7 @@ twasWeightsCv <- function( fitRetention, verbose ), - numThreads = numThreads, + BPPARAM = BPPARAM, maxNumVariants = maxNumVariants, variantsToKeep = variantsToKeep, fitRetention = fitRetention, @@ -2197,7 +2284,7 @@ twasWeightsCv <- function( # One TwasWeightsRow for a (variantIds, weights) pair with the shared flags. # @noRd .twasEntry <- function(variantIds, weights, fits, ctx) { - twasWeightsRow( + TwasWeightsRow( variantIds = variantIds, weights = weights, methodFits = fits, @@ -2265,10 +2352,11 @@ twasWeightsCv <- function( #' "enet_weights")) in which case default arguments will be used for all #' methods. methods in the list can be either univariate (applied to each #' column of Y) or multivariate (applied to the entire Y matrix). -#' @param numThreads The number of threads to use for parallel processing. If -#' set to -1, the function uses all available cores. If set to 0 or 1, no -#' parallel processing is performed. If set to 2 or more, parallel processing -#' is enabled with that many threads. +#' @param BPPARAM A \code{BiocParallelParam} the methods run on; +#' \code{SerialParam()} (default) runs them one at a time. Each draws from +#' its own random-number stream, seeded by \code{seed}, else by the param's +#' own \code{RNGseed}, else by one draw from the session RNG, so a run +#' gives the same numbers however many workers it has. #' @param fittedModels Named list of fitted SuSiE-family models, keyed by #' token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). #' Required whenever a SuSiE-family weight method is requested: those @@ -2297,10 +2385,9 @@ twasWeightsCv <- function( #' \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 +#' RNG and the streams the methods draw from (see \code{BPPARAM}). The #' main-process seed is scoped to the call, so the session RNG is left as it -#' was found. \code{NULL} (default) does not seed at all. +#' was found. \code{NULL} (default) seeds neither. #' @return A list where each element is named after a method and contains the #' weight matrix produced by that method. #' @@ -2328,7 +2415,7 @@ learnTwasWeights <- function( studyName = "", context = "", trait = "", - numThreads = 1, + BPPARAM = SerialParam(), fittedModels = NULL, fitRetention = c("none", "slim", "full"), weightStandardized = FALSE, @@ -2340,7 +2427,7 @@ learnTwasWeights <- function( assertString(studyName) assertString(context) assertString(trait) - assertInt(numThreads) + .assertBpparam(BPPARAM) fitRetention <- arg_match(fitRetention) assertFlag(weightStandardized) assertString(weightsDataType, null.ok = TRUE) @@ -2359,7 +2446,7 @@ learnTwasWeights <- function( studyName = studyName, context = context, trait = trait, - numThreads = numThreads, + BPPARAM = BPPARAM, fittedModels = fittedModels, fitRetention = fitRetention, weightStandardized = weightStandardized, @@ -2383,14 +2470,6 @@ learnTwasWeights <- function( Y } -# Number of BiocParallel workers to use: -1 means all available, otherwise the -# requested count capped at what is available. -# @noRd -.twasResolveCores <- function(numThreads) { - avail <- multicoreWorkers() - min(if (numThreads == -1) avail else numThreads, avail) -} - # Variant ids for the weight rows: colnames(X), or synthetic variant_i labels. # @noRd .twasVariantIds <- function(X) { @@ -2409,22 +2488,17 @@ learnTwasWeights <- function( colnames(X) } -# Fit every weight method (parallel when >= 2 cores, else serial map), keyed by -# method name. +# Fit every weight method on BPPARAM's workers, keyed by method name. # @noRd -.twasFitAllMethods <- function(weightMethods, ctx, numCores) { - weightsList <- if (numCores >= 2) { - bpParam <- .bpSeedParam(numCores, ctx$rngSeed) - bplapply( - names(weightMethods), - .computeMethodWeights, - weightMethods, - ctx, - BPPARAM = bpParam - ) - } else { - map(names(weightMethods), .computeMethodWeights, weightMethods, ctx) - } +.twasFitAllMethods <- function(weightMethods, ctx, BPPARAM) { + weightsList <- .bpMap( + names(weightMethods), + .computeMethodWeights, + weightMethods, + ctx, + BPPARAM = BPPARAM, + seed = ctx$rngSeed + ) set_names(weightsList, names(weightMethods)) } @@ -2471,7 +2545,7 @@ learnTwasWeights <- function( studyName, context, trait, - numThreads, + BPPARAM, fittedModels, fitRetention, weightStandardized, @@ -2503,11 +2577,7 @@ learnTwasWeights <- function( verbose = verbose, rngSeed = seed ) - weightsList <- .twasFitAllMethods( - prepared, - ctx, - .twasResolveCores(numThreads) - ) |> + weightsList <- .twasFitAllMethods(prepared, ctx, BPPARAM) |> .twasApplyRownames(X) rows <- .buildTwasWeightEntries(weightsList, .twasVariantIds(X), ctx) .twasLearnResult(rows, ldReference) @@ -2564,7 +2634,7 @@ learnTwasWeights <- function( #' data(multiTraitData) #' X <- multiTraitData$X[, 1:4] #' colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:4)) -#' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), +#' twe <- TwasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), #' weights = rep(0.1, 4), cvResult = list(rsq = 0.5), #' weightStandardized = FALSE) #' tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", @@ -2584,8 +2654,8 @@ twasPredict <- function(X, weightsList) { # for compatibility with the legacy snake_case "_predicted" # convention; ensembleWeights() rebinds the suffix. methodNames <- as.character(weightsList$method) - # The per-row weights live in each element's mcols now, so read them - # off the elements rather than a stored `entry` column. + # The per-row weights live in each element's mcols, so read them off + # the elements. wl <- set_names( map(seq_len(nrow(weightsList)), .twasRowWeights, x = weightsList), str_c(methodNames, "_weights") @@ -2683,8 +2753,7 @@ estimateSparsity <- function(weightResults) { ) } -# Column `cn` of `object`, extracted via `[[` (preserves the required `entry` -# column that `object[, cn]` would drop). +# Column `cn` of `object`'s mcols. # @noRd .twasColumn <- function(cn, object) { .tupleColumn(object, cn) diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 7d0afb5a..a603e345 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -49,14 +49,16 @@ #' #' @param ... Two or more \code{TwasWeights} objects, or a single \code{list} of #' them. -#' @param ldReference Optional genotype panel (see \code{\link{readGenotypes}}) -#' to attach to the -#' combined collection. Default \code{NULL}. Applied when combining two or +#' @param ldReference Optional LD reference -- a genotype panel (see +#' \code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +#' \code{LdMatrix} -- that every row of the combined collection uses instead +#' of its own. Default \code{NULL}: each row keeps the reference it had, +#' and views of one source are stored once. Applied when combining two or #' more inputs; a single input is returned unchanged. #' @return A single combined \code{TwasWeights}. #' @seealso \code{\link{combineFineMappingResults}} #' @examples -#' twe <- twasWeightsRow( +#' twe <- TwasWeightsRow( #' variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), #' cvResult = list(rsq = 0.5), weightStandardized = FALSE) #' tw1 <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", @@ -132,7 +134,7 @@ combineTwasWeights <- function(..., ldReference = NULL) { } else { unname(list_c(wList)) } - twasWeightsRow( + TwasWeightsRow( variantIds = unname(list_c(map(payloads, .twrPartsVariantIds))), weights = stacked, methodFits = set_names(map(payloads, methodFits), fittedLabels), @@ -182,10 +184,11 @@ combineTwasWeights <- function(..., ldReference = NULL) { # Per the design: BGLR / qgg "Bayes alphabet" methods (bayes_a/b/c/l/n/r, # 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 (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). +# dpr_vb / dpr_adaptive_gibbs remain individual-only. lasso, enet and ridge +# are glmnet on individual data and the penalized RSS solver on summary +# statistics, at alpha = 1, 0.5 (or the caller's) and 0. 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 / @@ -228,10 +231,14 @@ combineTwasWeights <- function(..., ldReference = NULL) { sumstatImpl = "sdprWeights", multivariate = FALSE ), - # Individual-only -- no cpp11 sumstat solver yet. enet = list( individualImpl = "enetWeights", - sumstatImpl = NULL, + sumstatImpl = "enetRssWeights", + multivariate = FALSE + ), + ridge = list( + individualImpl = "ridgeWeights", + sumstatImpl = "ridgeRssWeights", multivariate = FALSE ), # Individual-only DPR variants (sumstat counterparts not implemented). @@ -398,6 +405,7 @@ combineTwasWeights <- function(..., ldReference = NULL) { "susieInf", "mrash", "enet", + "ridge", "lasso", "bayesR", "bayesL", @@ -430,6 +438,7 @@ combineTwasWeights <- function(..., ldReference = NULL) { susie_ash_inf = "susieAsh", mrash = "mrash", enet = "enet", + ridge = "ridge", lasso = "lasso", bayesR = "bayesR", bayesL = "bayesL", @@ -816,7 +825,7 @@ combineTwasWeights <- function(..., ldReference = NULL) { if (length(mv) == 0L) { return(invisible(NULL)) } - components <- qtlDatasets(data) + components <- as.list(data) if (length(components) == 0L) { return(invisible(NULL)) } @@ -875,11 +884,11 @@ combineTwasWeights <- function(..., ldReference = NULL) { # set is a subset of the ldReference panel. # @noRd .twasAssertQcd <- function(sumstats) { - if (length(qcInfo(sumstats)) == 0L) { + if (length(qcOptions(sumstats)) == 0L) { cls <- class(sumstats)[[1L]] msg <- glue( "twasWeightsPipeline: the supplied {cls} has no QC record ", - "(qcInfo is empty). Call summaryStatsQc() first and pass the ", + "(qcOptions() is empty). Call summaryStatsQc() first and pass the ", "QC-applied result." ) abort(msg) @@ -931,7 +940,7 @@ combineTwasWeights <- function(..., ldReference = NULL) { tokens, .twasFitForToken, fineMappingResult = fineMappingResult, - study = studyName, + studyName = studyName, context = context, trait = trait ), @@ -1082,20 +1091,25 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' (require at least two traits OR at least two contexts). #' \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. +#' \item \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. +#' \item \code{lasso}, \code{enet} and \code{ridge} are glmnet on +#' individual-level data and the penalized RSS solver on summary +#' statistics. \code{enet} mixes the two penalties at +#' \code{alpha = 0.5} unless the method's options set it, on either +#' input: \code{methods = list(enet = list(alpha = 0.3))}. #' } #' #' 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{ldReference} slot -#' is set automatically: \code{NULL} for individual-level fits, the input's -#' \code{ldReference} for RSS-derived fits. +#' Each row of the returned \code{\link{TwasWeights}} collection records the +#' LD reference its weights were learned against: none for individual-level +#' fits, the reference of the input row(s) for RSS-derived fits. #' #' Optionally a \code{QtlFineMappingResult} may be supplied as a source of #' pre-fit SuSiE / SuSiE-inf / SuSiE-ash objects; their stored fits are passed @@ -1122,9 +1136,9 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' 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 +#' @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. @@ -1136,14 +1150,19 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' (\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. +#' trait) pairs a per-context entry leaves out. In a MultiStudyQtlDataset +#' a study left with no trait selected sits out; the run is refused only +#' when no study or summary-statistics row has one. #' @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 -#' \code{traitId}. +#' \code{GRanges}. Mutually exclusive with \code{traitId}. #' @param cisWindow For QtlDataset: cis-window (bp) around each trait's genomic #' position when extracting variants. Required when \code{traitId} is -#' supplied. Mutually exclusive with \code{region}. +#' supplied. Mutually exclusive with \code{region}. For QtlSumStats: +#' optional; each selected tuple is analysed over its \code{traitPos} +#' \eqn{\pm} \code{cisWindow}, within its \code{region}, which is then +#' the window its result records. Every selected tuple needs a +#' \code{traitPos}. A MultiStudyQtlDataset applies it to each of its +#' studies, individual-level or summary-statistics, as above. #' @section Panel filters on the RSS path: On \code{QtlSumStats} input there #' is no genotype matrix to filter, so \code{panelFilterParam}'s #' \code{mafCutoff} / \code{macCutoff} / \code{imissCutoff} are measured @@ -1158,12 +1177,11 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' \code{summaryStatsQc(raissParam = ...)}, which only bounds which variants #' RAISS will impute. #' -#' @param genotypeFilterParam For QtlDataset: per-call genotype-filter -#' overrides, built with \code{\link{GenotypeFilterParam}}. Each field that is -#' set replaces the corresponding construct-time \code{\link{QtlDataset}} slot -#' for this call only (applied to a validated copy); a field left unset -#' leaves the stored value in place. Variant QC is a property of the data, -#' so these are applied identically here and in +#' @param genotypeFilterParam For QtlDataset: which variants and samples the +#' run keeps, built with \code{\link{GenotypeFilterParam}}: its +#' \code{keepSamples} narrows the dataset once, and its other settings +#' apply to each extracted block. A field left unset filters nothing. +#' These are applied identically here and in #' \code{\link{fineMappingPipeline}} --- there is deliberately no #' TWAS-specific variant filter. #' @param panelFilterParam For QtlSumStats: LD-reference-panel filters, @@ -1194,7 +1212,9 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' 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 -#' instead of refitting. +#' instead of refitting. Its fits and cross-validation are reused whole, +#' so a row narrowed since its fit warns (condition class +#' \code{pecotmrFitCoverage}). #' @param twasWeights Optional \code{\link{TwasWeights}} resume cache. For each #' requested \code{(study, context, trait, method)} tuple already present in #' this collection, the cached \code{TwasWeightsRow} is copied through and @@ -1226,13 +1246,17 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' of the returned object's contract. #' #' \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 +#' statistics, by \code{lasso}, \code{enet}, \code{ridge}, \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 phenotypeFilterParam The run's phenotype QC, built with +#' \code{\link{PhenotypeFilterParam}}: how missing phenotype values are +#' handled (unset drops the affected samples; \code{"impute"} fills each +#' trait's mean; a fit cannot take \code{"keep"}) and whether outlier +#' samples are dropped. Every fit of the run, joint ones included, reads +#' its phenotypes under it. #' @param crossValidationParam Cross-validation settings, built with #' \code{\link{CrossValidationParam}}: \code{folds} (default \code{0}, no #' CV), \code{threads}, \code{samplePartition}, \code{maxVariants} (cap @@ -1279,11 +1303,10 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' @section The genotype scale: #' Individual-level genotypes reach every method centred and scaled to unit #' variance, so all the weights are on one scale and the recorded -#' \code{weight_standardized} says so. The scaling belongs to the -#' \code{QtlDataset} accessors rather than to this pipeline: -#' \code{\link{residualizedGenotypes}} applies it, governed by -#' \code{ResidualizationParam(scaleResiduals = )} per call with the -#' dataset's own \code{\link{scaleResiduals}} slot as the default. +#' \code{weight_standardized} says so. The residualization +#' (\code{\link{residualizedGenotypes}}) applies it, governed by +#' \code{ResidualizationParam(scaleResiduals = )}, which defaults to +#' \code{TRUE}. #' #' It is not cosmetic: measured through pecotmr's own entry points, every #' method returns coefficients on the scale of the \code{X} it was given @@ -1308,9 +1331,10 @@ combineTwasWeights <- function(..., ldReference = NULL) { #' @param ... Reserved for method-specific arguments. #' #' @return A \code{\link{TwasWeights}} collection keyed by \code{(study, -#' 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. +#' context, trait, method)}. Each row's LD reference is none for +#' individual-level fits and that of the input row(s) for RSS-derived fits. +#' Its \code{seqinfo()} names the genome build the inputs name; inputs +#' naming different builds are refused. #' @examples #' data(qtlDatasetExample) #' twasWeightsPipeline(qtlDatasetExample, methods = "lasso", cisWindow = 1e6) @@ -1382,6 +1406,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { dataDrivenPriorMatricesCv, cisWindow, residualizationParam, + genotypeFilter, verbose ) { # A per-context selection goes in whole: the joint scope then takes each @@ -1400,6 +1425,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, verbose = verbose ) ) @@ -1419,8 +1445,9 @@ setGeneric("twasWeightsPipeline", function(data, ...) { twasWeights, dataDrivenPriorMatricesCv, cisWindow, - naAction, + phenotypeFilter, residualizationParam, + genotypeFilter, usePCA, nPCs, verbose @@ -1436,14 +1463,12 @@ setGeneric("twasWeightsPipeline", function(data, ...) { dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, verbose = verbose )) } .twasQdsUnivariateEngine( - studyName = grid$study, - useCtx = grid$useCtx, - allTraits = grid$allTraits, - traitSelection = grid$traitSelection, + grid, marker = marker, data = data, xRegions = xRegions, @@ -1452,8 +1477,9 @@ setGeneric("twasWeightsPipeline", function(data, ...) { twasWeights = twasWeights, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, usePCA = usePCA, nPCs = nPCs, verbose = verbose @@ -1508,12 +1534,17 @@ setGeneric("twasWeightsPipeline", function(data, ...) { fitRetention = c("slim", "none", "full"), residualizationParam = ResidualizationParam(), weightsDataType = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, seed = NULL ) { - naAction <- arg_match(naAction) + phenotypeFilter <- .twasResolvePhenotypeFilter(phenotypeFilterParam) fitRetention <- arg_match(fitRetention) + build <- .inputsBuild( + list(data, region, fineMappingResult, twasWeights), + "twasWeightsPipeline" + ) + .fitCoverageCheckedRows(fineMappingResult, "twasWeightsPipeline()") contexts <- parseContexts(contexts, data) traitId <- parseTraitIds(traitId, data) .twasQdsAssertParams( @@ -1531,6 +1562,8 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ) data <- resolved$data cfg <- .twasJointCfg( + genotypeFilter = resolved$genotypeFilter, + phenotypeFilter = phenotypeFilter, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -1562,7 +1595,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { traitId ) if (joint$done) { - return(joint$result) + return(.withGenome(joint$result, build)) } grid <- .twasQdsResolveGrid( data, @@ -1581,13 +1614,14 @@ setGeneric("twasWeightsPipeline", function(data, ...) { twasWeights = twasWeights, dataDrivenPriorMatricesCv = setup$ctx$dataDrivenPriorMatricesCv, cisWindow = cisWindow, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam, + genotypeFilter = resolved$genotypeFilter, usePCA = usePCA, nPCs = nPCs, verbose = verbose ) - .twasQdsAssemble(tw, joint$result) + .withGenome(.twasQdsAssemble(tw, joint$result), build) } #' @rdname twasWeightsPipeline @@ -1644,10 +1678,10 @@ setMethod( ) } -# Reject the region + cisWindow combination, derive the X windows, and apply -# the per-call filter overrides to a validated copy of the dataset. Mirrors -# .fmQdsResolveInputs; variant QC is a data property applied identically to -# fine-mapping and TWAS, so there is no TWAS-specific variant filter. +# Reject the region + cisWindow combination, derive the X windows, resolve the +# run's genotype filter and narrow the dataset to its samples. Mirrors +# .fmQdsResolveInputs; variant QC is applied identically to fine-mapping and +# TWAS, so there is no TWAS-specific variant filter. # @noRd .twasQdsResolveInputs <- function( data, @@ -1661,9 +1695,11 @@ setMethod( cisWindow, "twasWeightsPipeline(QtlDataset)" ) + genotypeFilter <- .qtlResolveFilter(genotypeFilterParam) list( - data = .qtlApplyFilterOverrides(data, genotypeFilterParam), - xRegions = .makeXRegions(region, jointRegions) + data = .qtlRestrictSamples(data, genotypeFilter$keepSamples), + xRegions = .makeXRegions(region, jointRegions), + genotypeFilter = genotypeFilter ) } @@ -1747,11 +1783,25 @@ setMethod( list(parsedJointSpec = parsedJointSpec, norm = norm) } +# TWAS's phenotype QC: a weight fit cannot take a missing phenotype, so an +# unset naAction drops the affected samples and "keep" is refused. +# @noRd +.twasResolvePhenotypeFilter <- function(phenotypeFilterParam) { + .qtlResolvePhenotypeFilter( + phenotypeFilterParam, + naDefault = "drop", + naAllowed = c("drop", "impute"), + caller = "twasWeightsPipeline" + ) +} + # 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( + genotypeFilter, + phenotypeFilter, contexts, traitId, cisWindow, @@ -1768,6 +1818,8 @@ setMethod( seed ) { list( + genotypeFilter = genotypeFilter, + phenotypeFilter = phenotypeFilter, contexts = contexts, traitId = traitId, cisWindow = cisWindow, @@ -1800,7 +1852,7 @@ setMethod( ), ensembleParam = .ensembleResolve(cfg$ensembleParam), weightsDataType = cfg$weightsDataType, - standardized = .qtlScaleResiduals(data, cfg$residualizationParam), + standardized = .qtlScaleResiduals(cfg$residualizationParam), fitRetention = cfg$fitRetention, estimatePi = cfg$estimatePi, verbose = cfg$verbose, @@ -1816,6 +1868,8 @@ setMethod( dataDrivenPriorMatricesCv = mash$dataDrivenPriorMatricesCv, cisWindow = cfg$cisWindow, residualizationParam = cfg$residualizationParam, + genotypeFilter = cfg$genotypeFilter, + phenotypeFilter = cfg$phenotypeFilter, verbose = cfg$verbose ) ) @@ -1859,8 +1913,8 @@ setMethod( .twasQdsResolveTraits <- function(data, useCtx, traitId, region) { perCtxTraits <- map( useCtx, - .twasQdsCtxTraits, - data = data, + .contextSelectedTraits, + qd = data, traitId = traitId, region = region ) @@ -1895,9 +1949,8 @@ setMethod( fitRetention = fitRetention, # DERIVED from what the accessors actually do: genotypes reach # the fitter scaled to unit variance unless - # `ResidualizationParam(scaleResiduals = FALSE)` or the dataset's - # own slot says otherwise. Resolved by the caller, which is where - # the dataset and the bundle are both in scope. + # `ResidualizationParam(scaleResiduals = FALSE)` says otherwise. + # Resolved by the caller, which holds the bundle. standardized = standardized, estimatePi = estimatePi, verbose = verbose, @@ -1937,12 +1990,10 @@ setMethod( # Univariate methods ROUTED THROUGH THE ENGINE: one 1-condition group per # (context, trait), per region -> the SAME per-method fitter (+ ensemble layer # for >= 2 methods + resume cache) as the joint paths, merged across regions. +# `grid` is the dispatch row naming the study, contexts and traits. # @noRd .twasQdsUnivariateEngine <- function( - studyName, - useCtx, - allTraits, - traitSelection, + grid, marker, data, xRegions, @@ -1951,18 +2002,19 @@ setMethod( twasWeights, dataDrivenPriorMatricesCv, cisWindow, - naAction, + phenotypeFilter, residualizationParam, + genotypeFilter, usePCA, nPCs, verbose ) { plan <- .twasQdsUnivPlan( usePCA, - studyName, - useCtx, - allTraits, - traitSelection + grid$study, + grid$useCtx, + grid$allTraits, + grid$traitSelection ) cells <- plan$cells scope <- plan$scope @@ -1980,8 +2032,9 @@ setMethod( twasWeights = twasWeights, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, nPCs = nPCs, verbose = verbose ) @@ -1999,8 +2052,9 @@ setMethod( twasWeights, dataDrivenPriorMatricesCv, cisWindow, - naAction, + phenotypeFilter, residualizationParam, + genotypeFilter, nPCs, verbose ) { @@ -2013,8 +2067,9 @@ setMethod( region = xRegions[[bi]], regionIndex = bi, nRegions = length(xRegions), - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, nPCs = nPCs, verbose = verbose ) @@ -2061,6 +2116,7 @@ setMethod( methods = NULL, contexts = NULL, traitId = NULL, + cisWindow = NULL, jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, @@ -2077,11 +2133,17 @@ setMethod( "twasWeightsPipeline", "QtlSumStats" ) - .twasPipelineQtlSumStats( + build <- .inputsBuild( + list(data, fineMappingResult, twasWeights), + "twasWeightsPipeline" + ) + .fitCoverageCheckedRows(fineMappingResult, "twasWeightsPipeline()") + res <- .twasPipelineQtlSumStats( data = data, methods = methods, contexts = contexts, traitId = traitId, + cisWindow = cisWindow, jointSpecification = jointSpecification, fineMappingResult = fineMappingResult, twasWeights = twasWeights, @@ -2090,6 +2152,7 @@ setMethod( verbose = verbose, panelFilterParam = panelFilterParam ) + .withGenome(res, build) } ) @@ -2105,7 +2168,6 @@ setMethod( studyCol = part$studyCol, contextCol = part$contextCol, traitCol = part$traitCol, - ldReference = part$ldReference, methodArgs = methodArgs ) c( @@ -2138,11 +2200,21 @@ setMethod( ) } +# A QtlSumStats TWAS-weights run's inputs: its data, checked for a QC +# record, and its selection parsed once, with `cisWindow` laid on the tuples +# selected. +# @noRd +.twasQssInputs <- function(data, contexts, traitId, cisWindow) { + .twasAssertQcd(data) + .qssSelection(data, contexts, traitId, cisWindow, "twasWeightsPipeline") +} + .twasPipelineQtlSumStats <- function( data, methods, contexts, traitId, + cisWindow, jointSpecification, fineMappingResult, twasWeights, @@ -2151,15 +2223,13 @@ setMethod( verbose, panelFilterParam ) { - .twasAssertQcd(data) - contexts <- parseContexts(contexts, data) - traitId <- parseTraitIds(traitId, data) + inputs <- .twasQssInputs(data, contexts, traitId, cisWindow) # 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, + data = inputs$data, + contexts = inputs$contexts, + traitId = inputs$traitId, weightsDataType = weightsDataType, verbose = verbose, fitRetention = fitRetention, @@ -2175,10 +2245,10 @@ setMethod( return(joint$result) } .twasQssAfterJoint( - data, + inputs$data, joint = joint, - contexts = contexts, - traitId = traitId, + contexts = inputs$contexts, + traitId = inputs$traitId, twasWeights = twasWeights, weightsDataType = weightsDataType, fineMappingResult = fineMappingResult, @@ -2220,7 +2290,7 @@ setMethod( panelFilterParam = panelFilterParam ) ) - .twasQssAssemble(rows, joint$result, part$ldReference) + .twasQssAssemble(rows, joint$result, data) } # Normalize the methods argument into (tokens, methodArgs). The default set @@ -2341,8 +2411,7 @@ setMethod( traitCol = traitCol, selRows = selRows, multivariateTokens = multivariateTokens, - univariateTokens = univariateTokens, - ldReference = ldReference(data) + univariateTokens = univariateTokens ) } @@ -2404,19 +2473,27 @@ setMethod( ) } -# Assemble a TwasWeights collection from a flat list of row records. +# Assemble a TwasWeights collection from a flat list of row records, each row +# on the LD reference its record carries (none for an individual-level fit), +# and on the trait position and window `data` holds for its (study, context, +# trait) -- the window a cisWindow laid, which the result promises to record. # @noRd -.twasRowsToWeights <- function(rows, ldReference) { +.twasRowsToWeights <- function(rows, data) { if (length(rows) == 0L) { return(NULL) } + studies <- map_chr(rows, "study") + contexts <- map_chr(rows, "context") + traits <- map_chr(rows, "trait") TwasWeights( - studyName = map_chr(rows, "study"), - context = map_chr(rows, "context"), - trait = map_chr(rows, "trait"), + studyName = studies, + context = contexts, + trait = traits, method = map_chr(rows, "method"), entry = map(rows, "entry"), - ldReference = ldReference + traitPos = .anchorVector(data, studies, contexts, traits, "traitPos"), + region = .anchorVector(data, studies, contexts, traits, "region"), + ldReference = map(rows, "ldReference") ) } @@ -2498,7 +2575,6 @@ setMethod( contextCol, traitCol, data, - ldReference, twasWeights, weightsDataType, fitRetention, @@ -2517,7 +2593,6 @@ setMethod( contextCol = contextCol, traitCol = traitCol, data = data, - ldReference = ldReference, twasWeights = twasWeights, weightsDataType = weightsDataType, fitRetention = fitRetention, @@ -2560,7 +2635,6 @@ setMethod( contextCol, traitCol, data, - ldReference, twasWeights, weightsDataType, fitRetention, @@ -2572,10 +2646,11 @@ setMethod( ctx <- contextCol[i] tr <- traitCol[i] cached <- .twasQssCacheSplit(twasWeights, st, ctx, tr, univariateTokens) - cachedRows <- cached$rows + ldReference <- .rowLdRef(data, i) + cachedRows <- .recordsWithLdRef(unname(cached$rows), ldReference) toFit <- cached$toFit if (length(toFit) == 0L) { - return(unname(cachedRows)) + return(cachedRows) } fitCtx <- .twasQssUnivariateFitCtx( data, @@ -2597,7 +2672,7 @@ setMethod( fineMappingResult = fineMappingResult, weightsDataType = weightsDataType )) - c(unname(cachedRows), fitted) + c(cachedRows, .recordsWithLdRef(fitted, ldReference)) } # Cache hits for ONE multivariate group: a named list of the group's rows, @@ -2663,7 +2738,7 @@ setMethod( ldReference, cutoffs = NULL ) { - allDf <- as.data.frame( + allDf <- .sumStatsDf( data, studyName = st, context = ctx, @@ -2793,7 +2868,7 @@ setMethod( ctx, tr, tk, - twasWeightsRow( + TwasWeightsRow( variantIds = fitCtx$variantIds, weights = as.numeric(`attr<-`(weights, "fit", NULL)), methodFits = attr(weights, "fit"), @@ -2833,7 +2908,6 @@ setMethod( contextCol, traitCol, data, - ldReference, methodArgs, fitRetention, fineMappingResult, @@ -2859,7 +2933,6 @@ setMethod( contextCol = contextCol, traitCol = traitCol, data = data, - ldReference = ldReference, methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, @@ -2877,7 +2950,6 @@ setMethod( contextCol, traitCol, data, - ldReference, methodArgs, fitRetention, fineMappingResult, @@ -2888,37 +2960,70 @@ setMethod( if (length(gIdx) < 2L) { return(list()) } - st <- studyCol[gIdx[[1L]]] - tr <- traitCol[gIdx[[1L]]] - ctxNames <- contextCol[gIdx] - mvStat <- .twasQssMultivariateStat( + grp <- .twasQssMultivariateGroup( + gIdx, data, - st, - tr, - ctxNames, - ldReference = ldReference, - cutoffs = .panelCutoffs(panelFilterParam) - ) - # The group's block of the reference, read once and shared by every method. - blockReference <- .ldRefInMemory( - ldReference, - mvStat$variantIds, - label = "twasWeightsPipeline" + studyCol, + contextCol, + traitCol, + panelFilterParam ) - list_flatten(map( + rows <- list_flatten(map( multivariateTokens, .twasQssMultivariateFitOne, twasWeights = twasWeights, - st = st, - tr = tr, - ctxNames = ctxNames, - mvStat = mvStat, - blockReference = blockReference, + st = grp$st, + tr = grp$tr, + ctxNames = grp$ctxNames, + mvStat = grp$mvStat, + blockReference = grp$blockReference, methodArgs = methodArgs, fitRetention = fitRetention, fineMappingResult = fineMappingResult, weightsDataType = weightsDataType )) + .recordsWithLdRef(rows, grp$ldReference) +} + +# What every method fitted to one (study, trait) group shares: the study, +# trait and contexts, their LD reference, the stacked statistics, and the +# group's block of the reference, read once. The contexts are fitted together +# against one LD matrix, so they must share an LD reference. +# @noRd +.twasQssMultivariateGroup <- function( + gIdx, + data, + studyCol, + contextCol, + traitCol, + panelFilterParam +) { + ldReference <- .jointRowsLdRef( + data, + gIdx, + "twasWeightsPipeline (QtlSumStats, multivariate)" + ) + ctxNames <- contextCol[gIdx] + mvStat <- .twasQssMultivariateStat( + data, + studyCol[gIdx[[1L]]], + traitCol[gIdx[[1L]]], + ctxNames, + ldReference = ldReference, + cutoffs = .panelCutoffs(panelFilterParam) + ) + list( + st = studyCol[gIdx[[1L]]], + tr = traitCol[gIdx[[1L]]], + ctxNames = ctxNames, + ldReference = ldReference, + mvStat = mvStat, + blockReference = .ldRefInMemory( + ldReference, + mvStat$variantIds, + label = "twasWeightsPipeline" + ) + ) } # Build the (variants x contexts) Z matrix + per-context N for a group. All @@ -2933,7 +3038,7 @@ setMethod( ldReference = NULL, cutoffs = NULL ) { - allDf <- as.data.frame( + allDf <- .sumStatsDf( data, studyName = st, context = ctxNames[[1L]], @@ -2965,7 +3070,7 @@ setMethod( # One context's z column and median N, checked against the shared SNP order. # @noRd .twasQssContextStats <- function(ctx, data, st, tr, variantIds) { - d <- as.data.frame( + d <- .sumStatsDf( data, studyName = st, context = ctx, @@ -3218,12 +3323,8 @@ setMethod( # Combine the per-tuple result with any joint result (error if both empty). # @noRd -.twasQssAssemble <- function( - rows, - jointResult, - ldReference -) { - perTupleResult <- .twasRowsToWeights(rows, ldReference) +.twasQssAssemble <- function(rows, jointResult, data) { + perTupleResult <- .twasRowsToWeights(rows, data) if (is.null(jointResult)) { if (is.null(perTupleResult)) { msg <- glue( @@ -3237,7 +3338,7 @@ setMethod( if (is.null(perTupleResult)) { return(jointResult) } - .rbindTwasWeights(perTupleResult, jointResult, ldReference = ldReference) + .rbindTwasWeights(perTupleResult, jointResult) } # ============================================================================= @@ -3261,25 +3362,25 @@ setMethod( # @noRd .twasPerStudy <- function(qd, cfg) { # `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) { + # own share, and a study left with no trait selected in its selected + # contexts -- none of its contexts, none of the traits -- sits out. + if (!.studyHasSelectedTraits(qd, cfg$contexts, cfg$traitId, cfg$region)) { return(NULL) } - twasWeightsPipeline( + s <- studyName(qd) + .muffleFitCoverage(twasWeightsPipeline( data = qd, jointSpecification = NULL, fitRetention = cfg$fitRetention, methods = cfg$methods, - contexts = contexts, + contexts = .selectedContexts(cfg$contexts, s), traitId = .studyTraitIdArg(cfg$traitId, s), region = cfg$region, cisWindow = cfg$cisWindow, jointRegions = cfg$jointRegions, fineMappingResult = cfg$fineMappingResult, twasWeights = cfg$twasWeights, - naAction = cfg$naAction, + phenotypeFilterParam = cfg$phenotypeFilterParam, verbose = cfg$verbose, crossValidationParam = cfg$crossValidationParam, ensembleParam = cfg$ensembleParam, @@ -3291,16 +3392,17 @@ setMethod( nPCs = cfg$nPCs, weightsDataType = cfg$weightsDataType, residualizationParam = cfg$residualizationParam - ) + )) } # Embedded-sumstats TWAS-weights worker for .multiStudyPipelineDriver. # @noRd .twasSumStats <- function(ss, cfg) { - # Summary statistics carry no genotypes: nothing to select a region - # from, residualize, cross-validate, stack or fit on full data. `cfg` - # carries those for the individual-level sibling and they are not - # forwarded here. + # Summary statistics carry no genotypes: each tuple's window is in the + # input, narrowed by `cisWindow` around its trait position as on the + # QtlDataset side, and there is nothing to 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 @@ -3309,19 +3411,20 @@ setMethod( if (!any(keepRows)) { return(NULL) } - twasWeightsPipeline( + .muffleFitCoverage(twasWeightsPipeline( data = if (all(keepRows)) ss else ss[which(keepRows)], jointSpecification = NULL, fitRetention = cfg$fitRetention, methods = cfg$methods, contexts = NULL, traitId = NULL, + cisWindow = cfg$cisWindow, fineMappingResult = cfg$fineMappingResult, twasWeights = cfg$twasWeights, verbose = cfg$verbose, panelFilterParam = cfg$panelFilterParam, weightsDataType = cfg$weightsDataType - ) + )) } # Few methods distinguish the retention levels (.twasFullDetailTokens()); @@ -3365,7 +3468,7 @@ setMethod( # @noRd .twasFullDetailTokens <- function(inputKind) { if (identical(inputKind, "QtlSumStats")) { - return(c("mrmash", "lasso", "scad", "mcp", "l0learn")) + return(c("mrmash", "lasso", "enet", "ridge", "scad", "mcp", "l0learn")) } "mrmash" } @@ -3448,7 +3551,7 @@ setMethod( nPCs = 10L, fitRetention = c("slim", "none", "full"), weightsDataType = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, residualizationParam = ResidualizationParam(), crossValidationParam = CrossValidationParam(), @@ -3459,14 +3562,21 @@ setMethod( # 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") + # Resolved once here so a bad choice fails before any study runs; the + # record carries the bundle itself, as each component resolves its own. + .twasResolvePhenotypeFilter(phenotypeFilterParam) + build <- .inputsBuild( + list(data, region, fineMappingResult, twasWeights), + "twasWeightsPipeline(MultiStudyQtlDataset)" + ) + # Once here; each study's run below reads the same rows and is muffled. + .fitCoverageCheckedRows(fineMappingResult, "twasWeightsPipeline()") inputs <- .msResolveInputs( - naAction, region, cisWindow, jointRegions, "twasWeightsPipeline(MultiStudyQtlDataset)" ) - naAction <- inputs$naAction cfg <- .twasMsCfg( methods = methods, contexts = parseContexts(contexts, data), @@ -3476,7 +3586,7 @@ setMethod( jointRegions = jointRegions, fineMappingResult = fineMappingResult, twasWeights = twasWeights, - naAction = naAction, + phenotypeFilterParam = phenotypeFilterParam, verbose = verbose, crossValidationParam = crossValidationParam, ensembleParam = ensembleParam, @@ -3491,6 +3601,7 @@ setMethod( weightsDataType = weightsDataType, residualizationParam = residualizationParam ) + .msAssertTraitsSelected(data, cfg, "twasWeightsPipeline") jointCfg <- .twasMsJointCfg(cfg, data, inputs$xRegions) joint <- .twasMsResolveTokens( jointSpecification, @@ -3499,9 +3610,16 @@ setMethod( jointCfg ) if (joint$done) { - return(joint$result) + return(.withGenome(joint$result, build)) } - .twasMsDriver(data, joint$result, list_assign(cfg, methods = joint$methods)) + .withGenome( + .twasMsDriver( + data, + joint$result, + list_assign(cfg, methods = joint$methods) + ), + build + ) } # The MultiStudyQtlDataset joint record, derived from the record the @@ -3514,6 +3632,10 @@ setMethod( .twasMsJointCfg <- function(cfg, data, xRegions) { list_assign( .twasJointCfg( + genotypeFilter = .qtlResolveFilter(cfg$genotypeFilterParam), + phenotypeFilter = .twasResolvePhenotypeFilter( + cfg$phenotypeFilterParam + ), contexts = cfg$contexts, traitId = cfg$traitId, cisWindow = cfg$cisWindow, @@ -3644,7 +3766,7 @@ setMethod( jointRegions, fineMappingResult, twasWeights, - naAction, + phenotypeFilterParam, verbose, crossValidationParam, ensembleParam, @@ -3668,7 +3790,7 @@ setMethod( jointRegions = jointRegions, fineMappingResult = fineMappingResult, twasWeights = twasWeights, - naAction = naAction, + phenotypeFilterParam = phenotypeFilterParam, verbose = verbose, crossValidationParam = crossValidationParam, ensembleParam = ensembleParam, @@ -4540,28 +4662,12 @@ ensembleWeights <- function( regionIndex = bi, nRegions = length(ctx$xRegions), residualizationParam = ctx$residualizationParam, + genotypeFilter = ctx$genotypeFilter, + phenotypeFilter = ctx$phenotypeFilter, verbose = ctx$verbose ) } -# 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, .selectedTraits(traitId, studyName(data), ctx) %||% ids) - } else if (!is.null(region)) { - rr <- SummarizedExperiment::rowRanges(se) - ids[IRanges::overlapsAny(rr, region)] - } else { - ids - } -} - # One region's univariate joint-cell fit (region `bi` of `xRegions`). # @noRd .twasQdsUnivRegion <- function( @@ -4576,8 +4682,9 @@ ensembleWeights <- function( twasWeights, dataDrivenPriorMatricesCv, cisWindow, - naAction, + phenotypeFilter, residualizationParam, + genotypeFilter, nPCs, verbose ) { @@ -4591,8 +4698,9 @@ ensembleWeights <- function( twasWeights = twasWeights, dataDrivenPriorMatricesCv = dataDrivenPriorMatricesCv, cisWindow = cisWindow, - naAction = naAction, + phenotypeFilter = phenotypeFilter, residualizationParam = residualizationParam, + genotypeFilter = genotypeFilter, nPCs = nPCs, verbose = verbose ) @@ -4670,7 +4778,7 @@ ensembleWeights <- function( ctxNames[[kk]], tr, tk, - twasWeightsRow( + TwasWeightsRow( variantIds = mvStat$variantIds, weights = as.numeric(weights[, kk]), methodFits = if (kk == 1L) fitAttr else NULL, diff --git a/R/twasWeightsRow.R b/R/twasWeightsRow.R index 0c01ede2..ca37ac5e 100644 --- a/R/twasWeightsRow.R +++ b/R/twasWeightsRow.R @@ -11,7 +11,7 @@ NULL #' @title TWAS Weights Row #' @description One row's worth of TWAS weights. Build one with -#' \code{\link{twasWeightsRow}} and pass a list of them as +#' \code{\link{TwasWeightsRow}} and pass a list of them as #' \code{\link{TwasWeights}}' \code{entry} argument. #' @slot variants A \code{GRanges} of the weighted variants. #' @slot weights Per-variant weights, aligned to \code{variants}. @@ -19,7 +19,14 @@ NULL #' @slot cvResult Cross-validation payload, or \code{NULL}. #' @slot weightStandardized Whether the weights are on the standardized scale. #' @slot weightsDataType Optional data-type label. -#' @seealso \code{\link{twasWeightsRow}}, +#' @slot fitVariants The ids of the variants the weights were fitted on, in +#' the fit's own order, recorded when the row is built; empty for a row with +#' no fit payload. A row narrowed to fewer variants keeps them, which is how +#' reading its fits can tell they describe more variants than the row now +#' holds. +#' @section Coercion: \code{as(x, "GRanges")} gives the row's variants with +#' their \code{weight} column: the element a collection stores for it. +#' @seealso \code{\link{TwasWeightsRow}}, #' \code{\linkS4class{FineMappingRow}} #' @export setClass( @@ -30,14 +37,16 @@ setClass( methodFits = "ANY", cvResult = "ANY", weightStandardized = "logical", - weightsDataType = "ANY" + weightsDataType = "ANY", + fitVariants = "character" ), prototype( weights = NULL, methodFits = NULL, cvResult = NULL, weightStandardized = FALSE, - weightsDataType = NULL + weightsDataType = NULL, + fitVariants = character(0) ) ) @@ -80,9 +89,9 @@ methods::setValidity("TwasWeightsRow", function(object) { #' scale. #' @param weightsDataType Optional data-type label. #' @return A \code{\linkS4class{TwasWeightsRow}}. -#' @seealso \code{\link{fineMappingRow}} +#' @seealso \code{\link{FineMappingRow}} #' @examples -#' row <- twasWeightsRow( +#' row <- TwasWeightsRow( #' variantIds = c("chr1:100:A:G", "chr1:200:C:T"), #' weights = c(0.4, -0.2) #' ) @@ -91,7 +100,7 @@ methods::setValidity("TwasWeightsRow", function(object) { #' entry = list(row) #' ) #' @export -twasWeightsRow <- function( +TwasWeightsRow <- function( variantIds, weights, methodFits = NULL, @@ -120,17 +129,17 @@ twasWeightsRow <- function( gr, value = `[[<-`(mcols(gr, use.names = FALSE), "weight", value = w) ) - obj <- new( + fitted <- length(methodFits) > 0L || !is.null(cvResult) + new( "TwasWeightsRow", variants = withWeight, weights = w, methodFits = methodFits, cvResult = cvResult, weightStandardized = isTRUE(weightStandardized), - weightsDataType = weightsDataType + weightsDataType = weightsDataType, + fitVariants = if (fitted) .grVariantIds(gr) else character(0) ) - validObject(obj) - obj } @@ -154,6 +163,9 @@ setMethod("methodFits", "TwasWeightsRow", function(x) x@methodFits) #' @export setMethod("cvResult", "TwasWeightsRow", function(x) x@cvResult) +# @noRd +.twRowFitVariants <- function(x) x@fitVariants + #' @rdname weightStandardized #' @export setMethod("weightStandardized", "TwasWeightsRow", function(x) { @@ -167,6 +179,13 @@ setMethod("weightsDataType", "TwasWeightsRow", function(x) x@weightsDataType) # @noRd setMethod("variants", "TwasWeightsRow", function(x) x@variants) +#' @rdname TwasWeightsRow-class +#' @name coerce,TwasWeightsRow,GRanges-method +#' @aliases coerce,TwasWeightsRow,GRanges-method +#' @usage NULL +#' @exportMethod coerce +setAs("TwasWeightsRow", "GRanges", function(from) variants(from)) + #' @rdname show-methods #' @export setMethod("show", "TwasWeightsRow", function(object) { diff --git a/R/variantId.R b/R/variantId.R index 42970a79..0a585bfe 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -12,12 +12,6 @@ #' @importFrom magrittr is_in NULL -#' Strip "chr" prefix from chromosome identifiers. -#' @param x Character vector of chromosome identifiers (e.g., "chr1", "chrX"). -#' @return Character vector with "chr" prefix removed (e.g., "1", "X"). -#' @noRd -stripChrPrefix <- function(x) str_remove(x, "^chr") - #' Canonicalize chromosome identifiers to a normalized string. #' #' Strips a leading "chr"/"ch" prefix (case-insensitive), uppercases, drops @@ -52,16 +46,84 @@ canonChromLabel <- function(x) { replace(ok & x == "M", "MT") } -#' Ensure a leading chr prefix on a chromosome identifier. +#' Chromosome identifiers in the UCSC style. #' -#' Case-insensitive additive companion to \code{canonChrom} (which strips the -#' prefix): \code{"1"}, \code{"chr1"}, \code{"CHR1"} all become \code{"chr1"}. -#' Does not remap 23/24/M. +#' The style \code{seqlevelsStyle(x) <- "UCSC"} gives, and the only one pecotmr +#' holds: every chromosome label that enters -- read from a file, parsed from a +#' variant id, or passed to a constructor or as a range argument -- goes +#' through here once, so comparisons inside the package are exact. +#' \code{"1"}, \code{"chr1"}, +#' \code{"CHR1"} and \code{"01"} all become \code{"chr1"}; the numeric codes +#' fold as in \code{canonChrom} (\code{23 -> chrX}, \code{24 -> chrY}); and +#' the mitochondrion, \code{"M"} or \code{"MT"}, becomes \code{"chrM"}. A +#' label outside the standard set keeps its spelling behind the prefix. #' @param x Character or numeric vector of chromosome identifiers. -#' @return Character vector with a lowercase \code{"chr"} prefix. +#' @return Character vector of UCSC-style chromosome names. #' @noRd withChrPrefix <- function(x) { - str_c("chr", str_remove(as.character(x), regex("^chr", ignore_case = TRUE))) + bare <- str_remove(as.character(x), regex("^chr", ignore_case = TRUE)) + canon <- canonChrom(bare) + standard <- is_in(canon, .STANDARD_CHROMS) + str_c("chr", if_else(standard, str_replace(canon, "^MT$", "M"), bare)) +} + +# The chromosomes withChrPrefix() spells as UCSC does, in canonChrom() form. +# @noRd +.STANDARD_CHROMS <- c(as.character(seq_len(22L)), "X", "Y", "MT") + +# `gr` with its chromosomes in UCSC style, for ranges entering from outside: +# a constructor's ranges, a range argument. Strand, metadata columns and the +# genome build are kept, and ranges already in UCSC style come back as they +# are. Anything but ranges (NULL, a stray value a constructor is about to +# refuse) passes through untouched. +# @noRd +.ucscRanges <- function(gr) { + if (!methods::is(gr, "GenomicRanges") && !methods::is(gr, "GRangesList")) { + return(gr) + } + old <- GenomeInfoDb::seqlevels(gr) + new <- withChrPrefix(old) + if (identical(old, new)) { + return(gr) + } + if (!anyDuplicated(new)) { + return(GenomeInfoDb::renameSeqlevels(gr, set_names(new, old))) + } + # Two spellings of one chromosome ("1" and "chr1") cannot both be + # renamed onto one name, so the ranges are rebuilt on the merged names. + out <- S4Vectors::`mcols<-`( + GenomicRanges::GRanges( + withChrPrefix(as.character(GenomicRanges::seqnames(gr))), + IRanges::ranges(gr), + strand = GenomicRanges::strand(gr) + ), + value = S4Vectors::mcols(gr) + ) + .withGenome(out, .oneBuild(gr)) +} + +# A collection constructor's `entry` list with every element's chromosomes in +# UCSC style; a NULL element stays NULL. +# @noRd +.ucscEntries <- function(entry) { + map(as.list(entry), .ucscRanges) +} + +# A context or genotype experiment with its rowRanges in UCSC style, so a +# dataset compares them exactly with every other range pecotmr holds. +# @noRd +.ucscExperiment <- function(se) { + if (!methods::is(se, "RangedSummarizedExperiment")) { + return(se) + } + old <- GenomeInfoDb::seqlevels(se) + if (identical(withChrPrefix(old), old)) { + return(se) + } + SummarizedExperiment::`rowRanges<-`( + se, + value = .ucscRanges(SummarizedExperiment::rowRanges(se)) + ) } #' Order key for chromosome identifiers. @@ -81,16 +143,12 @@ chromOrder <- function(x) { factor(x, levels = c(standard, extra), ordered = TRUE) } -# Backwards-compat alias - #' Strip build suffix from variant IDs (e.g., ":b38" or "_b38"). #' @param x Character vector of variant IDs. #' @return Character vector with build suffix removed. #' @noRd stripBuildSuffix <- function(x) str_remove(x, "(:|_)b[0-9]+$") -# Backwards-compat alias - #' Test whether allele pairs are single-nucleotide (SNP, not indel). #' #' Returns TRUE for each pair where both alleles are exactly one of A, T, C, G. @@ -162,8 +220,6 @@ isSnpAlleles <- function(a1, a2) { ) } -# Backwards-compat alias - #' Detect the naming convention of variant IDs #' #' Examines variant ID strings to detect their format: whether they have a "chr" @@ -220,22 +276,21 @@ detectVariantConvention <- function(ids) { ) } -# Backwards-compat alias for external callers - #' Parse variant IDs into a data frame #' #' Converts variant IDs from any supported string format or data.frame into a -#' standardized data.frame with a normalized character chrom, integer pos, and -#' character allele columns (A2, A1). The chrom is canonicalized (chr stripped, -#' uppercased, 23 -> X / 24 -> Y / M -> MT) but kept as a string so X/Y/MT -#' survive. Supports colon-separated ("chr1:100:A:G"), underscore-separated -#' ("1_100_A_G"), with or without "chr" prefix, and with optional build suffix -#' (":b38" or "_b38"). The detected input convention is stored as an attribute. +#' standardized data.frame with a character chrom, integer pos, and character +#' allele columns (A2, A1). The chrom is spelled in UCSC style, as every +#' chromosome pecotmr holds is ("chr1", "chrX", "chrM"; 23 -> chrX, +#' 24 -> chrY). Supports colon-separated ("chr1:100:A:G"), +#' underscore-separated ("1_100_A_G"), with or without "chr" prefix, and with +#' optional build suffix (":b38" or "_b38"). The detected input convention is +#' stored as an attribute. #' #' @param ids A character vector of variant IDs, or a data.frame with columns #' "chrom", "pos", and allele columns (A2/A1 or ref/alt or any 4-column #' layout). -#' @return A tibble with columns "chrom" (character, normalized), "pos" +#' @return A tibble with columns "chrom" (character, UCSC style), "pos" #' (integer), "A2" (character), "A1" (character). The detected convention is #' stored as \code{attr(result, "convention")}. #' @examples @@ -259,7 +314,7 @@ parseVariantId <- function(ids) { # non-matching id yields an all-NA capture row (mirrors strcapture). m <- str_match(normalized, "^([^:]+):([^:]+):([^:]+):([^:]+)") data <- tibble( - chrom = canonChrom(m[, 2L]), + chrom = withChrPrefix(m[, 2L]), pos = as.integer(m[, 3L]), A2 = m[, 4L], A1 = m[, 5L] @@ -274,7 +329,7 @@ parseVariantId <- function(ids) { .withCanonicalCoords <- function(ids) { # `value =` named: tibble's `[[<-` method carries an extra `j` formal, so a # third POSITIONAL argument binds to `j` and the write silently misfires. - coerced <- `[[<-`(ids, "chrom", value = canonChrom(ids$chrom)) + coerced <- `[[<-`(ids, "chrom", value = withChrPrefix(ids$chrom)) `[[<-`(coerced, "pos", value = as.integer(ids$pos)) } @@ -323,8 +378,10 @@ parseVariantId <- function(ids) { #' @param pos Integer position. #' @param A2 Character reference allele. #' @param A1 Character alternate/effect allele. -#' @param chrPrefix Logical, whether to add "chr" prefix. Default TRUE. Ignored -#' if \code{convention} is provided. +#' @param chrPrefix Logical. \code{TRUE} (default) spells the chromosome in UCSC +#' style (\code{chr1}, \code{chrX}, \code{chrM}); \code{FALSE} writes it +#' bare (\code{1}, \code{X}, \code{MT}). Ignored if \code{convention} is +#' provided. #' @param alleleSep Character, separator between pos/A2 and A2/A1 fields. #' Default \code{":"} produces canonical \code{"chr1:100:A:G"}; \code{"_"} #' produces mixed \code{"chr1:100_A_G"}. Ignored if \code{convention} is @@ -353,18 +410,12 @@ formatVariantId <- function( ":" } } - # Normalize the chromosome (strip prefix, uppercase, map synonyms) then - # re-add the "chr" prefix if requested. canonChrom keeps X/Y/MT as strings. - chromClean <- canonChrom(chrom) - if (chrPrefix) { - str_c("chr", chromClean, ":", pos, alleleSep, A2, alleleSep, A1) - } else { - str_c(chromClean, ":", pos, alleleSep, A2, alleleSep, A1) - } + # UCSC style is pecotmr's own; the bare form is for a consumer that wants + # it (canonChrom keeps X/Y/MT as strings). + chromOut <- if (chrPrefix) withChrPrefix(chrom) else canonChrom(chrom) + str_c(chromOut, ":", pos, alleleSep, A2, alleleSep, A1) } -# Backwards-compat alias for external callers - #' Re-format variant IDs to a chosen output convention #' #' Output-only convenience: parses variant IDs and re-emits them in a single @@ -380,8 +431,10 @@ formatVariantId <- function( #' name-based downstream consumers. #' #' @param ids A character vector of variant IDs in any supported format. -#' @param chrPrefix Logical, whether to include "chr" prefix. Default TRUE. -#' Ignored if \code{convention} is provided. +#' @param chrPrefix Logical. \code{TRUE} (default) writes the chromosome in +#' UCSC style (\code{chr1}, \code{chrM}), the style pecotmr uses +#' throughout; \code{FALSE} writes it bare. Ignored if \code{convention} is +#' provided. #' @param convention Optional list from \code{detectVariantConvention} or #' \code{attr(parseVariantId(ids), "convention")}. When provided, the output #' format is driven automatically by the detected convention. @@ -1180,122 +1233,6 @@ matchVariants <- function( ) } -# Backwards-compat alias for external callers - -#' Parse a region string into its components -#' -#' Split a region identifier (e.g. \code{"chr1:100-200"} or -#' \code{"chr1_100_200"}) into chromosome, start and end. Non-character or -#' non-scalar input is returned unchanged. -#' -#' @param region A single region string. -#' @return A vector/list with the chromosome, start and end, or the input -#' unchanged when it is not a scalar string. -#' @importFrom stringr str_split -#' @examples -#' parseRegion("chr1:1000000-2000000") -#' parseRegion("chr1_1000000_2000000") -#' @export -parseRegion <- function(region) { - if (!is.character(region) || length(region) != 1) { - return(region) - } - - # Both documented spellings: "chr1:100-200" and the underscore form - # "chr1_100_200" that LD-block / region ids use. MT and M are accepted - # alongside X/Y -- canonChrom() below exists precisely to normalize them, - # and rejecting them here made that unreachable. - pattern <- "^chr[0-9XYMTm]+(:[0-9]+-[0-9]+|_[0-9]+_[0-9]+)$" - if (!str_detect(region, pattern)) { - abort( - "Input string format must be 'chr:start-end' or 'chr_start_end'." - ) - } - parts <- str_split_1(region, "[:_-]") - tibble( - chrom = canonChrom(parts[1]), - start = as.integer(parts[2]), - end = as.integer(parts[3]) - ) -} - -#' Utility function to convert LD region_ids to `region of interest` dataframe -#' -#' The first field is treated as the chromosome and kept as a normalized string -#' (via \code{canonChrom}) so X/Y/MT survive; the remaining fields are genomic -#' positions and are returned as integers. -#' @param ldRegionId A string of region in the format of chrom_start_end. -#' @param colnames Character vector of length 3 giving output column names for -#' chromosome, start and end. Default \code{c("chrom", "start", "end")}. -#' @return A tibble with one row per input region and columns named by -#' \code{colnames}: a normalized character chromosome plus integer start/end. -#' @examples -#' regionToDf(c("1_100_200", "2_300_400")) -#' @importFrom checkmate assertCharacter -#' @export -regionToDf <- function(ldRegionId, colnames = c("chrom", "start", "end")) { - # @param says "A string", but the function is vectorised and callers pass - # a character vector -- assert what it actually accepts, not the prose. - assertCharacter(ldRegionId, any.missing = FALSE) - assertCharacter(colnames, len = 3L, any.missing = FALSE) - parts <- str_split(ldRegionId, "[_:-]", simplify = TRUE) - regionOfInterest <- `colnames<-`( - as_tibble(parts, .name_repair = "minimal"), - colnames - ) - regionOfInterest |> - mutate( - across(all_of(colnames[1]), canonChrom), - across(all_of(colnames[-1]), as.integer) - ) -} - -# Backwards-compat alias for external callers - -#' Convert region specifications to a GRanges object -#' -#' Accepts region strings ("chr1:100-200", "1_100_200"), character vectors of -#' such strings, or data.frames with chrom/start/end columns. Returns a -#' \code{\link[GenomicRanges]{GRanges}} object. -#' -#' @param regions A region string, character vector, or data.frame with -#' chrom/start/end columns. -#' @return A \code{GRanges} object. -#' @examples -#' regions <- c("chr1:100-200", "chr1:300-400") -#' asGranges(regions = regions) -#' @export -asGranges <- function(regions) { - if (is.character(regions)) { - df <- regionToDf(regions) - } else if (is.data.frame(regions)) { - if (!all(is_in(c("chrom", "start", "end"), names(regions)))) { - abort("data.frame must have columns: chrom, start, end") - } - df <- regions - } else { - msg <- glue( - "regions must be a character vector or data.frame with ", - "chrom/start/end columns" - ) - abort(msg) - } - # GRanges expects character seqnames; prefix with "chr" if numeric - rawChrom <- as.character(df$chrom) - seqnames <- if (any(str_detect(rawChrom, "^chr"))) { - rawChrom - } else { - str_c("chr", rawChrom) - } - GenomicRanges::GRanges( - seqnames = seqnames, - ranges = IRanges::IRanges( - start = as.integer(df$start), - end = as.integer(df$end) - ) - ) -} - #' Classify variant type from allele strings #' #' Determines whether each variant is a SNP, insertion, deletion, or @@ -1360,8 +1297,8 @@ classifyVariantType <- function(ids) { # Build the element GRanges for a set of variant ids. # # Ids that do not encode coordinates are a CONSTRUCTION ERROR. Substituting a -# synthetic range would make range() lie, and range() is the block identity that -# subsetRegion() and the (tuple, range) uniqueness key are both built on -- a +# synthetic range would make range() lie, and range() is the block identity the +# (tuple, range) uniqueness key is built on -- a # fabricated coordinate corrupts both silently. # @noRd .variantIdsToGRanges <- function(ids, what = "variant ids") { @@ -1391,7 +1328,7 @@ classifyVariantType <- function(ids) { } gr <- S4Vectors::`mcols<-`( GenomicRanges::GRanges( - withChrPrefix(parsed$chrom), + parsed$chrom, IRanges::IRanges(start = parsed$pos, width = 1L) ), value = S4Vectors::DataFrame( diff --git a/_pkgdown.yml b/_pkgdown.yml index 7711362b..ebf5f9e3 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -153,7 +153,7 @@ reference: - ColocResult - CtwasResult - CtwasResultEntry - - fineMappingRow + - FineMappingRow - GenotypeMixture - GwasFineMappingResult - GwasSumStats @@ -169,7 +169,7 @@ reference: - qtlSumStatsFromZMatrix - SldscData - TwasWeights - - twasWeightsRow + - TwasWeightsRow - title: "Engine options and method parameters" desc: > @@ -238,6 +238,7 @@ reference: - EnsembleParam - FineMappingMethodsParam - GenotypeFilterParam + - PhenotypeFilterParam - GwasFineMappingParam - MashComponentParam - MashPriorParam @@ -292,7 +293,7 @@ reference: - flattenTupleRanges - nestTupleRanges - RangedTupleList-methods - - subsetRegion + - updateObject-methods - subtitle: "FineMappingResultBase" contents: @@ -315,8 +316,8 @@ reference: - variantIds - intersectVariants - resolveWeights - - exportToVcf - - exportToBed + - writeGwasVcf + - writeBed - readFineMappingResult - blockId @@ -343,8 +344,6 @@ reference: - subtitle: "ColocResultBase / ColocResult / ColocBoostResult" contents: - - "as.data.frame,ColocBoostResult-method" - - "as.data.frame,ColocResult-method" - colocViews - colocBoostOutcomes - computingTime @@ -358,31 +357,31 @@ reference: - ldReference - maf - nSamples + - sampleSize - variantColumnReplace + - fillFromReference - pval - qcDiagnostics - qcInfo + - qcOptions - se - studyName - variantIds - z - nSnps - - subsetChr - subtitle: "GwasSumStats" contents: - combineGwasSumStats - - sumStatsDataFrame - "sumStats,GwasSumStats-method" - varY - - exportToVcf + - writeGwasVcf - subtitle: "QtlSumStats" contents: - combineQtlSumStats - contexts - significantQtls - - sumStatsDataFrame - sumStats - traitPosition - traitNames @@ -406,8 +405,8 @@ reference: - variantIds - weights-methods - resolveWeights - - exportToVcf - - exportToBed + - writeGwasVcf + - writeBed - readTwasWeights - subtitle: "TwasWeightsRow" @@ -478,7 +477,6 @@ reference: - subtitle: "MultiStudyQtlDataset" contents: - - qtlDatasets - studyName - sumStats @@ -492,10 +490,8 @@ reference: - molecularTraits - residualizedGenotypes - residualizedPhenotypes - - scaleResiduals - studyName - traitPosition - - qtlDatasetFilters - subtitle: "SldscData" contents: @@ -588,9 +584,6 @@ reference: - parseVariantId - normalizeVariantId - classifyVariantType - - parseRegion - - regionToDf - - asGranges - genomicOrder - title: "Fine-mapping" @@ -643,7 +636,10 @@ reference: - glmnetWeights - lassoWeights - enetWeights + - ridgeWeights - lassosumRssWeights + - enetRssWeights + - ridgeRssWeights - mcpWeights - mcpRssWeights - scadWeights diff --git a/data/colocboostResultExample.rda b/data/colocboostResultExample.rda index 4b8e8373..7341fe87 100644 Binary files a/data/colocboostResultExample.rda and b/data/colocboostResultExample.rda differ diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 18d676b9..d4c11e06 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index a9e01ef3..70c1e431 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index 91e4e1bf..c39b82f8 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/data/ctwasWeightsExample.rda b/data/ctwasWeightsExample.rda index a1fe326a..e10a266a 100644 Binary files a/data/ctwasWeightsExample.rda and b/data/ctwasWeightsExample.rda differ diff --git a/data/fsusieFineMappingExample.rda b/data/fsusieFineMappingExample.rda index ed4d2e13..1ff2bc0e 100644 Binary files a/data/fsusieFineMappingExample.rda and b/data/fsusieFineMappingExample.rda differ diff --git a/data/gwasFineMappingExample.rda b/data/gwasFineMappingExample.rda index 6eb1977f..5c7db01a 100644 Binary files a/data/gwasFineMappingExample.rda and b/data/gwasFineMappingExample.rda differ diff --git a/data/gwasFineMappingLbfExample.rda b/data/gwasFineMappingLbfExample.rda index 19d08d1c..750835e9 100644 Binary files a/data/gwasFineMappingLbfExample.rda and b/data/gwasFineMappingLbfExample.rda differ diff --git a/data/gwasSumStatsS4Example.rda b/data/gwasSumStatsS4Example.rda index 8a24d963..3539a1cf 100644 Binary files a/data/gwasSumStatsS4Example.rda and b/data/gwasSumStatsS4Example.rda differ diff --git a/data/multiStudyQtlDatasetExample.rda b/data/multiStudyQtlDatasetExample.rda index 2587422d..0ae036dd 100644 Binary files a/data/multiStudyQtlDatasetExample.rda and b/data/multiStudyQtlDatasetExample.rda differ diff --git a/data/mvsusieFineMappingExample.rda b/data/mvsusieFineMappingExample.rda index eeae7d4e..80aee8ad 100644 Binary files a/data/mvsusieFineMappingExample.rda and b/data/mvsusieFineMappingExample.rda differ diff --git a/data/qtlDatasetExample.rda b/data/qtlDatasetExample.rda index 85ee38b0..581c1886 100644 Binary files a/data/qtlDatasetExample.rda and b/data/qtlDatasetExample.rda differ diff --git a/data/qtlFineMappingExample.rda b/data/qtlFineMappingExample.rda index 10bd11fc..b8fa121c 100644 Binary files a/data/qtlFineMappingExample.rda and b/data/qtlFineMappingExample.rda differ diff --git a/data/qtlFineMappingLbfExample.rda b/data/qtlFineMappingLbfExample.rda index b9a92118..e58fbf47 100644 Binary files a/data/qtlFineMappingLbfExample.rda and b/data/qtlFineMappingLbfExample.rda differ diff --git a/data/qtlFineMappingPairedExample.rda b/data/qtlFineMappingPairedExample.rda index a44a5a4f..2c572b00 100644 Binary files a/data/qtlFineMappingPairedExample.rda and b/data/qtlFineMappingPairedExample.rda differ diff --git a/data/qtlSumStatsExample.rda b/data/qtlSumStatsExample.rda index 190200d2..203f2dde 100644 Binary files a/data/qtlSumStatsExample.rda and b/data/qtlSumStatsExample.rda differ diff --git a/data/qtlSumStatsMulticontextExample.rda b/data/qtlSumStatsMulticontextExample.rda index 28eef0b7..b5c756f5 100644 Binary files a/data/qtlSumStatsMulticontextExample.rda and b/data/qtlSumStatsMulticontextExample.rda differ diff --git a/data/twasWeightsExample.rda b/data/twasWeightsExample.rda index b1abdd58..957426ce 100644 Binary files a/data/twasWeightsExample.rda and b/data/twasWeightsExample.rda differ diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R index 682dff72..c0667737 100644 --- a/inst/scripts/build_ctwas_examples.R +++ b/inst/scripts/build_ctwas_examples.R @@ -70,8 +70,7 @@ gwasSumStats <- loadGwasSumStatsFromManifest( manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), genome = "hg38", ldReference = ldStem, - region = "chr22:10000000-19000000", - ldBlocks = blocks + which = blocks ) gwasByRegion <- summaryStatsQc( gwasSumStats, @@ -95,14 +94,14 @@ data(ctwasWeightsExample) # portable "pecotmr://extdata/" form afterwards -- the same two-step # every other bundled example uses. .resolveGenotypeResourcePath() turns it # back into a real path at read time, on whatever machine has the package. -ctwasWeightsExample <- methods::initialize( +ctwasWeightsExample <- pecotmr:::.withRowLdRefs( ctwasWeightsExample, - ldReference = pecotmr:::.asLdRef(.portableHandle(ldStem)) + .portableHandle(ldStem) ) stopifnot( path(pecotmr:::.ldRefHandle( - ldReference(ctwasWeightsExample) + ldReference(ctwasWeightsExample)[[1L]] )) == asBundledResource(ldStem) ) @@ -112,7 +111,8 @@ stopifnot( # ----------------------------------------------------------------------------- ctwasInputsExample <- assembleCtwasInputs( gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample) + twasWeights = list(ctwasWeightsExample), + method = "susie" ) ctwasEstExample <- estCtwasGroupPriors( diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index d6ca6d0e..03806e36 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -77,6 +77,27 @@ snpStats::write.plink( na.code = 0L ) gh <- readGenotypes(plink1Prefix = smallStem) + +# Point the panel at a portable bundled-resource reference +# ("pecotmr://extdata/") before any object is built from it, so the .rda +# objects carry no source-tree 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 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 +} +gh <- asPortablePanel(gh) windowSnpInfo <- pecotmr:::.rangesSnpInfo(SummarizedExperiment::rowRanges(gh)) # Materialise the dosage matrix once for synthetic-phenotype generation. @@ -116,7 +137,7 @@ phenoSe <- SummarizedExperiment::SummarizedExperiment( ) qtlDatasetExample <- QtlDataset( - study = "study1", + studyName = "study1", genotypes = gh, phenotypes = list(brain = phenoSe), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -152,13 +173,13 @@ S4Vectors::mcols(qtlGr) <- S4Vectors::DataFrame( ) qtlSumStatsExample <- QtlSumStats( - study = "study1", + studyName = "study1", context = "brain", trait = "ENSG_example", entry = list(qtlGr), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic example data; QC bypassed") + qcOptions = list(prebuilt = "synthetic example data; QC bypassed") ) # ----------------------------------------------------------------------------- @@ -188,11 +209,11 @@ S4Vectors::mcols(gwasGr) <- S4Vectors::DataFrame( ) gwasSumStatsS4Example <- GwasSumStats( - study = "trait1", + studyName = "trait1", entry = list(gwasGr), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic example data; QC bypassed") + qcOptions = list(prebuilt = "synthetic example data; QC bypassed") ) # ----------------------------------------------------------------------------- @@ -210,7 +231,7 @@ phenoSe2 <- SummarizedExperiment::SummarizedExperiment( ) qd2 <- QtlDataset( - study = "study2", + studyName = "study2", genotypes = gh, phenotypes = list(brain = phenoSe2), genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) @@ -283,60 +304,17 @@ multiCtxEntries <- map(multiCtxNames, function(ctx) { }) qtlSumStatsMulticontextExample <- QtlSumStats( - study = rep("study1", length(multiCtxNames)), + studyName = rep("study1", length(multiCtxNames)), context = multiCtxNames, trait = rep("ENSG_example", length(multiCtxNames)), entry = multiCtxEntries, genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic multi-context example; QC bypassed") -) - -# ----------------------------------------------------------------------------- -# 7. Point the PLINK1 panels at a portable bundled-resource reference -# ("pecotmr://extdata/") so the .rda objects carry no source-tree -# 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 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 <- repointDataset(qtlDatasetExample) -qtlSumStatsExample@ldReference <- asPortablePanel( - qtlSumStatsExample@ldReference -) -qtlSumStatsMulticontextExample@ldReference <- asPortablePanel( - qtlSumStatsMulticontextExample@ldReference -) -gwasSumStatsS4Example@ldReference <- asPortablePanel( - gwasSumStatsS4Example@ldReference -) -multiStudyQtlDatasetExample@qtlDatasets <- map( - multiStudyQtlDatasetExample@qtlDatasets, - repointDataset + qcOptions = list(prebuilt = "synthetic multi-context example; QC bypassed") ) # ----------------------------------------------------------------------------- -# 8. Save. +# 7. Save. # ----------------------------------------------------------------------------- usethis::use_data(qtlDatasetExample, overwrite = TRUE, compress = "xz") usethis::use_data(qtlSumStatsExample, overwrite = TRUE, compress = "xz") diff --git a/man/ColocBoostResult-class.Rd b/man/ColocBoostResult-class.Rd index 263dc8b4..61eaa447 100644 --- a/man/ColocBoostResult-class.Rd +++ b/man/ColocBoostResult-class.Rd @@ -12,11 +12,20 @@ A collection of ColocBoost results, one element per confidence \section{Slots}{ \describe{ +\item{\code{ldReference}}{A named list of the LD references the summary statistics +were matched against, each a genotype panel, a \code{GenotypeMixture} or +an \code{LdMatrix}, and each stored once however many outcomes used it. +Empty when no summary statistics were analysed.} + \item{\code{outcomeInfo}}{A data frame mapping each outcome \code{name} to its -\code{study}, \code{context}, \code{trait} and \code{dataForm}. ColocBoost -is given outcome names as bare labels, and those labels are lossy -- a -trait is context-qualified only when ambiguous -- so the mapping is -recorded when the names are minted rather than parsed back out later.} +\code{study}, \code{context}, \code{trait}, \code{dataForm} and +\code{ldReference}, the name of the \code{ldReference} entry its +summary statistics were matched against (\code{NA} for an +individual-level outcome, whose LD comes from its own genotypes). +ColocBoost is given outcome names as bare labels, and those labels are +lossy -- a trait is context-qualified only when ambiguous -- so the +mapping is recorded when the names are minted rather than parsed back +out later.} \item{\code{regionVcp}}{A \code{GRanges} of every variant in the analysed region carrying the marginal \code{vcp}. Collection-level: it spans the region, diff --git a/man/ColocBoostResult.Rd b/man/ColocBoostResult.Rd index d7d5e1dd..0235550a 100644 --- a/man/ColocBoostResult.Rd +++ b/man/ColocBoostResult.Rd @@ -11,7 +11,7 @@ ColocBoostResult( outcomeInfo = NULL, ldReference = NULL, computingTime = list(), - includeUncolocalized = TRUE + metadata = list() ) } \arguments{ @@ -27,20 +27,27 @@ analysis each element came from.} 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}.} +\code{context}, \code{trait} and \code{dataForm}, and optionally to +\code{ldReference}, the name of the \code{ldReference} entry the +outcome's summary statistics were matched against. Without that column +every outcome gets \code{NA}.} -\item{ldReference}{Optional genotype panel (see -\code{\link{readGenotypes}}).} +\item{ldReference}{Optional named list of the LD references the summary +statistics were matched against: genotype panels (see +\code{\link{readGenotypes}}), \code{GenotypeMixture} or \code{LdMatrix} +objects.} \item{computingTime}{Optional list of per-analysis timings.} -\item{includeUncolocalized}{Keep the outcome-specific (uncolocalized) sets -as elements flagged \code{isColocalized = FALSE}. Default \code{TRUE}: -dropping them at write time would make "no colocalization here" and "no -signal here" indistinguishable downstream.} +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ -A \code{ColocBoostResult}. +A \code{ColocBoostResult}. The outcome-specific (uncolocalized) + sets are kept as elements flagged \code{isColocalized = FALSE}, so "no + colocalization here" stays distinct from "no signal here"; + \code{x[x$isColocalized]} keeps the colocalized ones. } \description{ Assemble a \code{\linkS4class{ColocBoostResult}} from the raw diff --git a/man/ColocResult-class.Rd b/man/ColocResult-class.Rd index a1eb4c4f..cc6b82ea 100644 --- a/man/ColocResult-class.Rd +++ b/man/ColocResult-class.Rd @@ -11,9 +11,18 @@ A collection of colocalization results, one element per tested \code{\link{colocCredibleSets}} and \code{\link{colocGenes}}. } \details{ -The inherited \code{ldReference} is what - \code{colocCredibleSets()} uses to compute credible-set purity. +The \code{ldReference} is what \code{colocCredibleSets()} uses to + compute credible-set purity, each pair's from its own reference. } +\section{Slots}{ + +\describe{ +\item{\code{ldReference}}{A named list of the LD references the pairs were computed +against, each a genotype panel, a \code{GenotypeMixture} or an +\code{LdMatrix}, stored once apiece; the \code{ldReference} column of +\code{mcols} names the entry each pair used (\code{NA} for none).} +}} + \seealso{ \code{\link{colocPipeline}} } diff --git a/man/ColocResult.Rd b/man/ColocResult.Rd index e20eaf18..13681a46 100644 --- a/man/ColocResult.Rd +++ b/man/ColocResult.Rd @@ -4,7 +4,7 @@ \alias{ColocResult} \title{Build a ColocResult} \usage{ -ColocResult(pairs, variants, ldReference = NULL) +ColocResult(pairs, variants, ldReference = NULL, metadata = list()) } \arguments{ \item{pairs}{A data frame with one row per tested pair, carrying at least @@ -18,9 +18,15 @@ 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{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) -for the LD reference, used by \code{\link{colocCredibleSets}} to -compute purity.} +\item{ldReference}{Optional LD reference -- a genotype panel (see +\code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +\code{LdMatrix} -- for every pair, or a list with one per pair; used by +\code{\link{colocCredibleSets}} to compute purity. Each distinct +reference is stored once.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ A \code{ColocResult}. diff --git a/man/ColocResultBase-class.Rd b/man/ColocResultBase-class.Rd index 3c4e20ac..5849da1d 100644 --- a/man/ColocResultBase-class.Rd +++ b/man/ColocResultBase-class.Rd @@ -17,14 +17,9 @@ Virtual base shared by \code{\linkS4class{ColocResult}} (from 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. -} -\section{Slots}{ - -\describe{ -\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.} -}} + Each subclass carries its own LD reference, and both answer + \code{\link{ldReference}}: a \code{ColocResult} holds the one reference + its pairs were computed against, a \code{ColocBoostResult} one per + reference its summary statistics were matched against. +} diff --git a/man/CredibleSetParam.Rd b/man/CredibleSetParam.Rd index a2dd06b0..83599c88 100644 --- a/man/CredibleSetParam.Rd +++ b/man/CredibleSetParam.Rd @@ -3,69 +3,41 @@ \docType{class} \name{csCoverage} \alias{csCoverage} -\alias{csCoverage<-} \alias{secondaryCoverage} -\alias{secondaryCoverage<-} \alias{signalCutoff} -\alias{signalCutoff<-} \alias{minAbsCorr} -\alias{minAbsCorr<-} \alias{medianAbsCorr} -\alias{medianAbsCorr<-} \alias{includeAllCs} -\alias{includeAllCs<-} \alias{perCsColumns} -\alias{perCsColumns<-} \alias{maxNumSingleEffects} \alias{maxNumSingleEffectsGreedy} \alias{CredibleSetParam-class} \alias{CredibleSetParam} \alias{csCoverage,CredibleSetParam-method} -\alias{csCoverage<-,CredibleSetParam-method} \alias{secondaryCoverage,CredibleSetParam-method} -\alias{secondaryCoverage<-,CredibleSetParam-method} \alias{signalCutoff,CredibleSetParam-method} -\alias{signalCutoff<-,CredibleSetParam-method} \alias{minAbsCorr,CredibleSetParam-method} -\alias{minAbsCorr<-,CredibleSetParam-method} \alias{medianAbsCorr,CredibleSetParam-method} -\alias{medianAbsCorr<-,CredibleSetParam-method} \alias{includeAllCs,CredibleSetParam-method} -\alias{includeAllCs<-,CredibleSetParam-method} \alias{perCsColumns,CredibleSetParam-method} -\alias{perCsColumns<-,CredibleSetParam-method} \alias{maxNumSingleEffects,CredibleSetParam-method} \alias{maxNumSingleEffectsGreedy,CredibleSetParam-method} \title{Credible-Set Construction And Reporting} \usage{ csCoverage(x, ...) -csCoverage(x, ...) <- value - secondaryCoverage(x, ...) -secondaryCoverage(x, ...) <- value - signalCutoff(x, ...) -signalCutoff(x, ...) <- value - minAbsCorr(x, ...) -minAbsCorr(x, ...) <- value - medianAbsCorr(x, ...) -medianAbsCorr(x, ...) <- value - includeAllCs(x, ...) -includeAllCs(x, ...) <- value - perCsColumns(x, ...) -perCsColumns(x, ...) <- value - maxNumSingleEffects(x, ...) maxNumSingleEffectsGreedy(x, ...) @@ -84,32 +56,18 @@ CredibleSetParam( \S4method{csCoverage}{CredibleSetParam}(x) -\S4method{csCoverage}{CredibleSetParam}(x) <- value - \S4method{secondaryCoverage}{CredibleSetParam}(x) -\S4method{secondaryCoverage}{CredibleSetParam}(x) <- value - \S4method{signalCutoff}{CredibleSetParam}(x) -\S4method{signalCutoff}{CredibleSetParam}(x) <- value - \S4method{minAbsCorr}{CredibleSetParam}(x) -\S4method{minAbsCorr}{CredibleSetParam}(x) <- value - \S4method{medianAbsCorr}{CredibleSetParam}(x) -\S4method{medianAbsCorr}{CredibleSetParam}(x) <- value - \S4method{includeAllCs}{CredibleSetParam}(x) -\S4method{includeAllCs}{CredibleSetParam}(x) <- value - \S4method{perCsColumns}{CredibleSetParam}(x) -\S4method{perCsColumns}{CredibleSetParam}(x) <- value - \S4method{maxNumSingleEffects}{CredibleSetParam}(x) \S4method{maxNumSingleEffectsGreedy}{CredibleSetParam}(x) @@ -119,8 +77,6 @@ CredibleSetParam( \item{...}{Unused, present for generic consistency.} -\item{value}{The replacement value for that setting.} - \item{coverage}{Primary credible-set coverage. Default \code{0.95}.} \item{secondaryCoverage}{Additional coverages to report credible sets at. @@ -161,10 +117,12 @@ where the engine has one. \value{ \code{CredibleSetParam} returns a \code{CredibleSetParam} object, a \code{\link{MethodParam}}. Each accessor returns that - setting's value; each replacement form returns a modified copy. - \code{maxNumSingleEffects} and \code{maxNumSingleEffectsGreedy} have - no replacement form: they are seeded onto the fitting tokens, so - changing one needs a refit rather than a re-summary. + setting's value. Change a setting with \code{x$ <- value} (the + field for \code{csCoverage()} is \code{coverage}), which returns a + modified copy; \code{maxNumSingleEffects} and + \code{maxNumSingleEffectsGreedy} cannot be changed that way: they are + seeded onto the fitting tokens, so changing one needs a refit rather + than a re-summary. } \description{ How credible sets are built from a fit and which of them are diff --git a/man/CrossValidationParam.Rd b/man/CrossValidationParam.Rd index 6ee6ac4c..360169ea 100644 --- a/man/CrossValidationParam.Rd +++ b/man/CrossValidationParam.Rd @@ -8,7 +8,7 @@ \usage{ CrossValidationParam( folds = 0, - numThreads = 1, + BPPARAM = SerialParam(), samplePartition = NULL, maxVariants = NULL, weightMethods = NULL, @@ -21,9 +21,12 @@ CrossValidationParam( \code{twasWeightsPipeline} used to default to \code{5}, which made an unspecified setting mean two different things.} -\item{numThreads}{Integer. Parallel workers for the per-fold refits. -\code{1} (default) is serial; \code{-1} uses all cores. Only consulted -when \code{folds > 1}.} +\item{BPPARAM}{A \code{BiocParallelParam} the per-fold refits run on; +\code{SerialParam()} (default) runs them one at a time. Its workers draw +from random-number streams seeded by the pipeline's \code{seed}, else by +the param's own \code{RNGseed}, else by one draw from the session RNG, +so a run gives the same numbers however many workers it has. Only +consulted when \code{folds > 1}.} \item{samplePartition}{Optional pre-defined partition \code{data.frame} with columns \code{Sample} and \code{Fold}. When supplied, every method @@ -55,13 +58,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}, \code{samplePartition} and + \code{folds}, \code{BPPARAM}, \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 = 10, BPPARAM = BiocParallel::SerialParam()) CrossValidationParam(folds = 5, fitFullData = FALSE) } diff --git a/man/CtwasResult-class.Rd b/man/CtwasResult-class.Rd index cf833834..8dc50ab2 100644 --- a/man/CtwasResult-class.Rd +++ b/man/CtwasResult-class.Rd @@ -5,18 +5,25 @@ \alias{CtwasResult-class} \title{cTWAS Result Collection} \description{ -S4 collection of cTWAS runs keyed by the identity tuple - \code{(gwasStudy, study, context, method)}. Each row holds a - \code{\linkS4class{CtwasResultEntry}} payload -- fine-mapping posteriors, - the jointly-estimated group priors, and region metadata -- for one run. +S4 collection of cTWAS runs, each keyed by the identity tuple + \code{(gwasStudy, study, context, method)} and split into one element per + cTWAS region, the way a \code{\linkS4class{GwasFineMappingResult}} holds + a genome-wide fit as one element per LD block. An element is a + \code{GRanges} of that region's gene (and, with \code{keepSnps}, SNP) + posteriors; \code{mcols()} carry the run identity, the region + (\code{blockId}), the region's per-effect susie alpha table + (\code{susieAlpha}), its region metadata (\code{regionInfo}) and the + run's jointly-estimated group priors (\code{groupPriors}), which repeat + on each of the run's rows. } \details{ Unlike the QTL family, \code{trait} is not part of the key: a cTWAS - run is multi-gene, so genes live inside the payload. The optional + run is multi-gene, so genes live inside the elements. The optional \code{jointStudies} / \code{jointContexts} columns tag rows born from a multi-study or multi-context run and participate in the uniqueness key, exactly as in the \code{\linkS4class{TwasWeights}} and fine-mapping - families. + families. \code{\link{ctwasPosteriors}} and \code{\link{susieAlpha}} + stack every region back into one \code{GRanges}. } \seealso{ \code{\link{CtwasResult}} for the constructor and diff --git a/man/CtwasResult.Rd b/man/CtwasResult.Rd index aa22f6f2..8e8fe068 100644 --- a/man/CtwasResult.Rd +++ b/man/CtwasResult.Rd @@ -11,7 +11,8 @@ CtwasResult( method, entry, jointStudies = NULL, - jointContexts = NULL + jointContexts = NULL, + metadata = list() ) } \arguments{ @@ -19,11 +20,13 @@ CtwasResult( \item{studyName}{Character vector of QTL study identifiers.} -\item{context}{Character vector of context labels (scalar per row).} +\item{context}{Character vector of context labels (scalar per run).} \item{method}{Character vector of weight-method names.} -\item{entry}{List / \code{SimpleList} of \code{CtwasResultEntry} objects.} +\item{entry}{List / \code{SimpleList} of \code{CtwasResultEntry} objects, +one per run; their posteriors and susie alpha tables must be +\code{GRanges}, which the pipeline builds them as.} \item{jointStudies}{Optional character vector (length \code{length(gwasStudy)}) listing the joined studies for a multi-study run, @@ -31,22 +34,34 @@ CtwasResult( \item{jointContexts}{Optional character vector for multi-context runs. Same shape as \code{jointStudies}.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ A \code{CtwasResult} object. } \description{ -Construct a \code{CtwasResult} DFrame-subclass collection of - cTWAS runs from per-tuple vectors and a list of - \code{\link{CtwasResultEntry}} payloads (one per run). A single-context run - is one row; a multi-context run emits per-context rows sharing the same - \code{jointContexts} set and jointly-estimated group priors. +Construct a \code{CtwasResult} collection of cTWAS runs from + per-run identity vectors and a list of \code{\link{CtwasResultEntry}} + payloads (one per run). Each run is split into one element per cTWAS + region -- by the payloads' \code{region_id}, or by chromosome when they + carry none -- so a single-context run is one row per region, and a + multi-context run emits per-context rows sharing the same + \code{jointContexts} set and jointly-estimated group priors. A run whose + payload holds no posteriors is kept as one empty element. } \examples{ +at <- IRanges::IRanges(c(100L, 200L), width = 1L) cre <- CtwasResultEntry( - posteriors = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1)), - susieAlpha = data.frame(id = c("g1", "g2"), alpha = c(0.9, 0.1))) -cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", context = "brain", - method = "susie", entry = list(cre)) + posteriors = GenomicRanges::GRanges("chr1", at, + id = c("g1", "g2"), region_id = "chr1_1_1000", + susie_pip = c(0.9, 0.1)), + susieAlpha = GenomicRanges::GRanges("chr1", at, + id = c("g1", "g2"), region_id = "chr1_1_1000", + susie_alpha = c(0.9, 0.1))) +cr <- CtwasResult(gwasStudy = "gwas1", studyName = "s1", + context = "brain", method = "susie", entry = list(cre)) cr } diff --git a/man/CtwasResultEntry-class.Rd b/man/CtwasResultEntry-class.Rd index f6890474..1fa7b057 100644 --- a/man/CtwasResultEntry-class.Rd +++ b/man/CtwasResultEntry-class.Rd @@ -3,6 +3,7 @@ \docType{class} \name{CtwasResultEntry-class} \alias{CtwasResultEntry-class} +\alias{coerce,CtwasResultEntry,GRanges-method} \title{cTWAS Per-Run Payload} \description{ Per-run cTWAS payload: the fine-mapping posterior table, the @@ -30,6 +31,12 @@ this run, or \code{NULL}.} \item{\code{regionInfo}}{Per-region metadata, or \code{NULL}.} }} +\section{Coercion}{ + \code{as(x, "GRanges")} gives the per-gene (and, with + SNPs kept, per-SNP) posteriors as ranges -- an error when they could not + be placed on the genome and are still a table. +} + \seealso{ \code{\link{CtwasResultEntry}} for the constructor. } diff --git a/man/DentistParam.Rd b/man/DentistParam.Rd index d152f77d..8fa4ca8c 100644 --- a/man/DentistParam.Rd +++ b/man/DentistParam.Rd @@ -13,7 +13,7 @@ DentistParam( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - numThreads = 1, + BPPARAM = SerialParam(), correctChenEtAlBug = TRUE, seed = NULL ) @@ -33,7 +33,10 @@ Default \code{0.4}.} \item{duprThreshold}{Duplicate r-squared threshold. Default \code{0.99}.} -\item{numThreads}{Number of CPU cores. Default \code{1}.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the +threads DENTIST's OpenMP loops use when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +thread. Default \code{SerialParam()}.} \item{correctChenEtAlBug}{Logical; apply the Chen et al. correction. Default \code{TRUE}.} diff --git a/man/FineMappingResultBase-class.Rd b/man/FineMappingResultBase-class.Rd index f41dc3a6..9ebb68c8 100644 --- a/man/FineMappingResultBase-class.Rd +++ b/man/FineMappingResultBase-class.Rd @@ -7,7 +7,8 @@ \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{ldReference} slot. + carry a \code{DFrame} of per-fit rows and an \code{ldReference} slot + listing the LD references those fits used. 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,10 +16,30 @@ Virtual base class for fine-mapping result collections. Concrete \section{Slots}{ \describe{ -\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.} +\item{\code{ldReference}}{A named list of the LD references the fits were +computed against, each a genotype panel, a \code{GenotypeMixture} or an +\code{LdMatrix}, stored once apiece; the \code{ldReference} column of +\code{mcols} names the entry each row used (\code{NA} for a fit derived +from individual-level data). Used downstream to check that the rows a +pipeline combines share an LD reference.} }} +\section{Narrowed rows}{ + Each row records in its \code{fitVariants} column + the ids of the variants its fit was made with (none for a row without a + fit). A row narrowed since -- by \code{endoapply()} or \code{[[<-} -- + keeps its fit as it was, so every reader of the fit warns, with + condition class \code{pecotmrFitCoverage}, when a row holds fewer + variants than its fit describes. The readers are the accessors + (\code{susieFit()}, \code{lbf()}, \code{cvResult()}, + \code{credibleSetSummary()} and the fSuSiE views), + \code{computeCsCorrelation()}, \code{susieResult()}, + \code{extractCsInfo()}, \code{extractTopPipInfo()}, + \code{writeGwasVcf()}, and the pipelines that score the fits: + \code{colocPipeline(adjustPips = FALSE)}, \code{qtlEnrichmentPipeline()} + and \code{twasWeightsPipeline()}. Values held per variant, such as + \code{topLoci()}, are narrowed with the row and do not warn. Nothing is + rescaled: \code{\link{intersectVariants}} restricts a fit explicitly, as + \code{colocPipeline()} does by default. +} + diff --git a/man/FineMappingRow-class.Rd b/man/FineMappingRow-class.Rd index 12603144..c5bf877e 100644 --- a/man/FineMappingRow-class.Rd +++ b/man/FineMappingRow-class.Rd @@ -3,10 +3,11 @@ \docType{class} \name{FineMappingRow-class} \alias{FineMappingRow-class} +\alias{coerce,FineMappingRow,GRanges-method} \title{Fine-Mapping Row} \description{ One row's worth of fine-mapping: the variants and the stored - fit. Build one with \code{\link{fineMappingRow}} and pass a list of them + fit. Build one with \code{\link{FineMappingRow}} and pass a list of them as a collection's \code{entry} argument. } \section{Slots}{ @@ -18,9 +19,20 @@ columns are the per-variant \code{topLoci} values.} \item{\code{susieFit}}{The stored fine-mapping fit, or \code{NULL}.} \item{\code{cvResult}}{Cross-validation payload, or \code{NULL}.} + +\item{\code{fitVariants}}{The ids of the variants the stored fit was made with, in +the fit's own order, recorded when the row is built; empty for a row with +no fit. A row narrowed to fewer variants keeps them, which is how reading +the fit can tell it describes more variants than the row now holds.} }} +\section{Coercion}{ + \code{as(x, "GRanges")} gives the row's variants with + their per-variant \code{topLoci} columns: the element a collection + stores for it. +} + \seealso{ -\code{\link{fineMappingRow}}, +\code{\link{FineMappingRow}}, \code{\linkS4class{TwasWeightsRow}} } diff --git a/man/fineMappingRow.Rd b/man/FineMappingRow.Rd similarity index 87% rename from man/fineMappingRow.Rd rename to man/FineMappingRow.Rd index 070b7913..2ebbe446 100644 --- a/man/fineMappingRow.Rd +++ b/man/FineMappingRow.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fineMappingRow.R -\name{fineMappingRow} -\alias{fineMappingRow} +\name{FineMappingRow} +\alias{FineMappingRow} \title{Build One Fine-Mapping Row} \usage{ -fineMappingRow(variantIds, susieFit, topLoci, cvResult = NULL) +FineMappingRow(variantIds, susieFit, topLoci, cvResult = NULL) } \arguments{ \item{variantIds}{Character vector of variant ids. Each must encode @@ -38,12 +38,12 @@ tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:C:T"), pip = c(0.9, 0.1) ) -row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) +row <- FineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) QtlFineMappingResult( studyName = "s1", context = "c1", trait = "g1", method = "susie", entry = list(row) ) } \seealso{ -\code{\link{twasWeightsRow}} +\code{\link{TwasWeightsRow}} } diff --git a/man/GenotypeFilterParam.Rd b/man/GenotypeFilterParam.Rd index 175f51f6..a887a35b 100644 --- a/man/GenotypeFilterParam.Rd +++ b/man/GenotypeFilterParam.Rd @@ -24,7 +24,9 @@ GenotypeFilterParam( \item{xvarCutoff}{Genotype-variance floor.} -\item{imissCutoff}{Per-variant missingness ceiling.} +\item{imissCutoff}{Per-sample missingness ceiling: a sample missing more +than this fraction of an extracted block's genotypes is dropped from +it.} \item{keepSamples}{Sample ids to restrict to; \code{character(0)} keeps all samples.} @@ -39,26 +41,20 @@ A \code{GenotypeFilterParam} object, a \code{\link{MethodParam}}. } \description{ Which variants and samples survive when a genotype matrix is - assembled, as one checked bundle. Used by \code{\link{QtlDataset}}, the - manifest loaders, and the pipelines that build a dataset. + assembled, as one checked bundle: the genotype QC of a run of + \code{\link{fineMappingPipeline}}, \code{\link{twasWeightsPipeline}} + or \code{\link{colocboostPipeline}} on a \code{\link{QtlDataset}}. + A \code{QtlDataset} records no filter of its own; \code{keepSamples} + narrows it once at the start of the run, and the other fields apply to + each extracted block, against that block's samples. } -\section{Unset versus set}{ +\section{Unset fields}{ - Every field defaults to \code{NULL}, meaning \strong{not set}, and an - unset field is absent from the result rather than carried as \code{NULL}. - That is what lets one bundle serve two roles: - \itemize{ - \item to \code{\link{QtlDataset}} it is a \emph{specification}, and - an unset field takes that constructor's own default --- \code{0} for - each cutoff, \code{character(0)} for each \code{keep}, \code{TRUE} - for \code{keepIndel}. - \item to a pipeline it is an \emph{override}, and an unset field - leaves the dataset's construct-time value alone. - } - So \code{GenotypeFilterParam(mafCutoff = 0)} and - \code{GenotypeFilterParam()} differ: the first pins the cutoff at zero, - the second defers. \code{\link{PanelFilterParam}} needs no such - distinction and keeps ordinary defaults. + Every field defaults to \code{NULL}, meaning \strong{not set}: an unset + field is absent from the result rather than carried as \code{NULL}, and + takes its default when the run resolves the bundle --- \code{0} for + each cutoff, no restriction for each \code{keep}, \code{TRUE} for + \code{keepIndel}. So \code{GenotypeFilterParam()} filters nothing. } \examples{ diff --git a/man/GenotypeHandle-class.Rd b/man/GenotypeHandle-class.Rd index 6bf82178..d5852c34 100644 --- a/man/GenotypeHandle-class.Rd +++ b/man/GenotypeHandle-class.Rd @@ -13,7 +13,7 @@ GenotypeHandle( pvar = NULL, psam = NULL, ldMeta = NULL, - region = NULL, + block = NULL, genoMeta = NULL, chroms = NULL, format = NULL @@ -29,17 +29,16 @@ GenotypeHandle( \item{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 +comma-separated as \code{ld_file,bim_file}). Requires \code{block}. The +constructor resolves the row covering \code{block}, then delegates to the 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}, -\code{start}, \code{end}.} +\item{block}{The \code{GRanges} window to look up in \code{ldMeta}; the +whole file of the row covering it is opened.} \item{genoMeta}{One-file-per-chromosome specification: a path to a \code{#chr,path} meta file or a named character vector (names = @@ -49,8 +48,8 @@ chromosomes, values = payload paths/prefixes). Optionally pass \item{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 -is genome-wide but only a few chromosomes are needed. Chromosome labels are -compared canonically (\code{"chr1"}/\code{"1"} match, \code{23}/\code{X} +is genome-wide but only a few chromosomes are needed. Chromosome labels may +be in any style (\code{"chr1"}/\code{"1"} match, \code{23}/\code{X} etc.). If none of the requested chromosomes are present in the panel, every 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 @@ -112,10 +111,10 @@ payload files live in \code{chromPaths}.} \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 -the shards were supplied), so \code{snpIdx} stays a single global index -space.} +\item{\code{snpInfo}}{data.frame, SNP metadata read from the index/sidecar, its +\code{CHR} in UCSC style whatever the file writes. 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 space.} \item{\code{nSamples}}{Integer, number of samples.} @@ -123,8 +122,9 @@ space.} \item{\code{pgenPtr}}{Opaque pointer for PLINK2 reader state (NULL otherwise).} -\item{\code{chromPaths}}{Named character vector mapping canonical chromosome (e.g. -\code{"21"}, \code{"X"}) to the per-chromosome payload path/prefix. Empty +\item{\code{chromPaths}}{Named character vector mapping each chromosome, in UCSC +style (e.g. \code{"chr21"}, \code{"chrX"}), to the per-chromosome +payload path/prefix. Empty (\code{character(0)}) for a single-file handle; non-empty marks a one-file-per-chromosome (sharded) handle whose extraction is routed by chromosome.} diff --git a/man/GenotypeMixture-class.Rd b/man/GenotypeMixture-class.Rd index f569ded8..9cda9439 100644 --- a/man/GenotypeMixture-class.Rd +++ b/man/GenotypeMixture-class.Rd @@ -11,6 +11,10 @@ \arguments{ \item{object}{A \code{GenotypeMixture}.} } +\value{ +\code{show} is called for its side effect and returns + \code{invisible(NULL)}. +} \description{ A \code{GenotypeMixture} uses several genotype panels (see \code{\link{readGenotypes}}) as one LD reference whose LD is the diff --git a/man/GwasFineMappingParam.Rd b/man/GwasFineMappingParam.Rd index bcb5a1ea..4d5d1d12 100644 --- a/man/GwasFineMappingParam.Rd +++ b/man/GwasFineMappingParam.Rd @@ -3,57 +3,33 @@ \docType{class} \name{fineMappingMethods} \alias{fineMappingMethods} -\alias{fineMappingMethods<-} \alias{credibleSetParam} -\alias{credibleSetParam<-} \alias{susieRssParam} -\alias{susieRssParam<-} \alias{panelFilterParam} -\alias{panelFilterParam<-} \alias{initializeWithSusieInf} -\alias{initializeWithSusieInf<-} \alias{fitRetention} -\alias{fitRetention<-} \alias{GwasFineMappingParam-class} \alias{GwasFineMappingParam} \alias{fineMappingMethods,GwasFineMappingParam-method} -\alias{fineMappingMethods<-,GwasFineMappingParam-method} \alias{credibleSetParam,GwasFineMappingParam-method} -\alias{credibleSetParam<-,GwasFineMappingParam-method} \alias{susieRssParam,GwasFineMappingParam-method} -\alias{susieRssParam<-,GwasFineMappingParam-method} \alias{panelFilterParam,GwasFineMappingParam-method} -\alias{panelFilterParam<-,GwasFineMappingParam-method} \alias{initializeWithSusieInf,GwasFineMappingParam-method} -\alias{initializeWithSusieInf<-,GwasFineMappingParam-method} \alias{fitRetention,GwasFineMappingParam-method} -\alias{fitRetention<-,GwasFineMappingParam-method} \title{Inline GWAS Fine-Mapping Settings} \usage{ fineMappingMethods(x, ...) -fineMappingMethods(x, ...) <- value - credibleSetParam(x, ...) -credibleSetParam(x, ...) <- value - susieRssParam(x, ...) -susieRssParam(x, ...) <- value - panelFilterParam(x, ...) -panelFilterParam(x, ...) <- value - initializeWithSusieInf(x, ...) -initializeWithSusieInf(x, ...) <- value - fitRetention(x, ...) -fitRetention(x, ...) <- value - GwasFineMappingParam( methods = "susie", credibleSetParam = CredibleSetParam(), @@ -65,35 +41,21 @@ GwasFineMappingParam( \S4method{fineMappingMethods}{GwasFineMappingParam}(x) -\S4method{fineMappingMethods}{GwasFineMappingParam}(x) <- value - \S4method{credibleSetParam}{GwasFineMappingParam}(x) -\S4method{credibleSetParam}{GwasFineMappingParam}(x) <- value - \S4method{susieRssParam}{GwasFineMappingParam}(x) -\S4method{susieRssParam}{GwasFineMappingParam}(x) <- value - \S4method{panelFilterParam}{GwasFineMappingParam}(x) -\S4method{panelFilterParam}{GwasFineMappingParam}(x) <- value - \S4method{initializeWithSusieInf}{GwasFineMappingParam}(x) -\S4method{initializeWithSusieInf}{GwasFineMappingParam}(x) <- value - \S4method{fitRetention}{GwasFineMappingParam}(x) - -\S4method{fitRetention}{GwasFineMappingParam}(x) <- value } \arguments{ \item{x}{A \code{GwasFineMappingParam}.} \item{...}{Unused, present for generic consistency.} -\item{value}{The replacement value for that setting.} - \item{methods}{Fine-mapping methods, as a character vector or a \code{\link{FineMappingMethodsParam}} record. Default \code{"susie"}.} @@ -124,8 +86,9 @@ result is handed back for other uses.} \code{GwasFineMappingParam} returns a \code{GwasFineMappingParam} object, a \code{\link{MethodParam}}. Each accessor returns that setting's value --- for the three nested - bundles, the \code{MethodParam} itself --- and each replacement form - returns a modified copy. + bundles, the \code{MethodParam} itself. Change a setting with + \code{x$ <- value} (the field for \code{fineMappingMethods()} + is \code{methods}), which returns a modified copy. } \description{ How \code{\link{colocPipeline}} fine-maps \code{gwasInput} diff --git a/man/GwasFineMappingResult.Rd b/man/GwasFineMappingResult.Rd index 4ce6f050..f5d01ed8 100644 --- a/man/GwasFineMappingResult.Rd +++ b/man/GwasFineMappingResult.Rd @@ -14,7 +14,8 @@ GwasFineMappingResult( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) } \arguments{ @@ -24,11 +25,13 @@ GwasFineMappingResult( \item{entry}{List / \code{SimpleList} of \code{FineMappingRow} objects.} -\item{blockId}{Optional character vector (per tuple) keying the external LD -block manifest, e.g. \code{"chr22_10516173_17414263"}. Provenance only, -not part of the identity key. Supply it when the block BOUNDARIES matter: -those are the one thing not recoverable from the variants, since adjacent -blocks' spans leave gaps.} +\item{blockId}{Optional character vector (per tuple) naming each row's +block, e.g. \code{"chr22_10516173_17414263"}. Provenance only, not part +of the identity key, and a name only: a block's boundaries, which the +variants cannot give since adjacent blocks' spans leave gaps, go in +\code{region}. Where it is \code{NULL}, or \code{NA} for a row, the +row's \code{blockId} is its own span, as \code{"chrom_start_end"}, so +every row is named by its block.} \item{traitPos}{Optional per-row trait genomic anchor (a \code{GRanges} or \code{NULL}), carried forward as provenance; not part of the identity key. @@ -36,18 +39,21 @@ blocks' spans leave gaps.} \item{region}{Optional per-row analysis WINDOW (a \code{GRanges} or \code{NULL}) -- the interval each row's fit was run over, carried -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.} +forward as provenance; not part of the identity key. It is recorded as +given, so each range must contain its row's variants. +\code{\link{fineMappingPipeline}} always sets it, from the window of the +input row. \code{NULL} (default) omits the column, and +\code{\link{genomicRegion}} then derives the window from the span of the +variants present.} \item{dataType}{Optional assay / modality label ("bulk_rnaseq", "methylation"), recorded as a per-row provenance column. Length 1 or 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{ldReference} cannot say which row came from which.} +\code{"individual"} or \code{"sumstat"}. Where it is absent, the result +writers read a row's kind from its LD reference: a row with none saw +individual-level data.} \item{weightStandardized}{Optional per-row flag: whether the posterior effect is on the STANDARDIZED genotype scale. The posterior effect IS the @@ -57,11 +63,22 @@ 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{ldReference}{An optional genotype panel (see -\code{\link{readGenotypes}}).} +\item{ldReference}{The LD reference the fits were computed against -- a +genotype panel (see \code{\link{readGenotypes}}), a +\code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +a list with one per row; \code{NULL} for none. Each distinct reference is +stored once.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ -A \code{GwasFineMappingResult} object. +A \code{GwasFineMappingResult} object. Its logical + \code{regionGiven} column says, per row, whether the window was given + or is the span of the variants; \code{\link{fineMappingPipeline}} + carries it over from the input. See \code{\linkS4class{GwasSumStats}} + for how the pipelines use it. } \description{ Construct a \code{GwasFineMappingResult} collection from @@ -72,13 +89,13 @@ Construct a \code{GwasFineMappingResult} collection from Rows are identified by (\code{study}, \code{method}) plus the element's own range, which is derived from the variants rather than stored, so it - cannot drift out of step with them and stays correct after - \code{\link{subsetRegion}}. + cannot drift out of step with them and stays correct when an element's + variants are narrowed. } \examples{ tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) -fe <- fineMappingRow( +fe <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl) GwasFineMappingResult(studyName = "t1", method = "susie", entry = list(fe)) } diff --git a/man/GwasSumStats-class.Rd b/man/GwasSumStats-class.Rd index c3980a98..87712f8e 100644 --- a/man/GwasSumStats-class.Rd +++ b/man/GwasSumStats-class.Rd @@ -6,15 +6,32 @@ \title{GWAS Summary-Statistic Collection} \description{ S4 collection of GWAS summary statistics keyed by the identity - tuple \code{(study)}. Each element is that study's per-variant - \code{GRanges} covering a single LD block, so build one collection per - block when sweeping the genome. + tuple \code{(study)}. A study is split into one element per chromosome, + or per window when \code{\link{GwasSumStats}} is given a \code{region}, + each a per-variant \code{GRanges}; \code{\link{sumStats}} and the other + accessors stitch a study's elements back together. } \details{ -Required column: \code{study}, unique across rows. The class-level - slots inherited from \code{\linkS4class{SumStatsBase}} -- - \code{ldReference}, \code{genome} and \code{qcInfo} -- apply uniformly to - every row. +Required column: \code{study}; the constructor also adds + \code{blockId}, naming each element's chromosome or window, and the + element's analysis window: \code{region}, a \code{GRanges} with one + range per element, and \code{regionGiven}. \code{regionGiven} is + \code{TRUE} where the window was given as a \code{region}, and + \code{FALSE} where it is the span of the element's variants when the + collection was first built, before any QC. A QC pass carries both + unchanged; the span of the variants left is \code{range(x)}. + \code{\link{colocPipeline}}, + \code{\link{colocboostPipeline}} and + \code{\link{causalInferencePipeline}} check the QTL variants against + these windows. Variants past a given window lie in one that was not + loaded, which is an error. Variants past a computed window may only be + ones the GWAS lacks, so more than one in a row is a warning. + A study repeats across its elements, so uniqueness is on + \code{(study, range)}. The class-level + slots inherited from \code{\linkS4class{SumStatsBase}} -- \code{genome} + and \code{qcOptions} -- apply uniformly to every row; \code{ldReference} + holds each distinct LD reference once, and the \code{ldReference} column + names the one each row uses. } \seealso{ \code{\link{GwasSumStats}} for the constructor and diff --git a/man/GwasSumStats.Rd b/man/GwasSumStats.Rd index f0d578fc..7e852968 100644 --- a/man/GwasSumStats.Rd +++ b/man/GwasSumStats.Rd @@ -13,25 +13,29 @@ GwasSumStats( nCase = NULL, nControl = NULL, nSample = NULL, - qcInfo = list(), - ldBlocks = NULL, + qcOptions = list(), + region = NULL, blockId = NULL, - extraCols = list() + extraCols = list(), + metadata = list() ) } \arguments{ -\item{studyName}{Character vector of study identifiers (must be unique).} +\item{studyName}{Character vector of study identifiers, one per +\code{entry}. A study whose entries are already split by block repeats +here, once per entry, with \code{blockId} telling them apart.} \item{entry}{A \code{SimpleList} or \code{list} of \code{GRanges}, one per -study.} +study (or per block of an already-split 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 reference.} +\code{"hg19"}, \code{"hg38"}). One build per collection.} \item{ldReference}{The LD reference: a genotype panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an -\code{\link{LdMatrix}}.} +\code{\link{LdMatrix}}, used for every study, or a list with one per +study when they sit on different references. Each distinct reference is +stored once, and the \code{ldReference} column names each row's.} \item{varY}{Optional numeric vector of per-study phenotype variances (\code{NA_real_} entries allowed). Used by the sufficient-statistic @@ -52,42 +56,50 @@ 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).} -\item{qcInfo}{A \code{list} recording which QC steps ran. Empty \code{list()} -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{qcOptions}{A \code{list} recording the QC that ran. Empty +\code{list()} on construction; \code{summaryStatsQc()} fills it. +Fine-mapping / TWAS pipelines reject inputs where +\code{length(qcOptions(x)) == 0}.} -\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 -this granularity: its EM estimates parameters across blocks, so a -per-chromosome split is too coarse. Variants overlapping no block are -dropped with a warning, because a variant outside every block has no -block-local LD to be fine-mapped against.} +\item{region}{Optional analysis windows, typically LD blocks: a +\code{GRanges}, or the path of a BED file, read as BED with a 0-based +start (a fourth column, when present, names each window). One set of +windows applies to every study; a list gives one set per study, +\code{NULL} for a study to split by chromosome. Each study's variants are +split into one element per window they fall in, rather than one per +chromosome, and each element's \code{region} is its window, recorded as +given. Its \code{blockId} is the window's name: its \code{names}, else +its \code{blockId} column (a BED file's fourth column), else its +coordinates. cTWAS needs this granularity: its EM estimates parameters +across blocks, so a per-chromosome split is too coarse. Variants outside +every window are dropped with a warning.} -\item{blockId}{Optional character vector of block keys, one per -\code{entry}, for entries that are \strong{already} split by block. Use -it to carry existing keys through a rebuild; without it a rebuild would -re-derive them as seqnames and collapse distinct blocks onto one key. -Mutually exclusive with \code{ldBlocks}.} +\item{blockId}{Optional character vector of block names, one per +\code{entry}, for entries that are \strong{already} split. Use it to +carry existing names through a rebuild; without it a rebuild would +re-derive them as seqnames and collapse distinct blocks onto one name. A +name only: it gives no window, which comes from \code{region}. Mutually +exclusive with \code{region}.} -\item{extraCols}{Optional named list of additional per-study columns to +\item{extraCols}{Optional named list (or \code{DataFrame} / +\code{data.frame}) of additional per-study columns to attach to the collection's \code{mcols}. Named rather than variadic because the base class's own constructor, \code{GRangesList(...)}, uses \code{...} for its \emph{elements}: a bare \code{...} here would read as adding an entry rather than a metadata column.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ 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 reference and a single genome build that apply - to the whole collection. +Construct a \code{GwasSumStats} S4 collection from per-study + tuple vectors and a list of \code{GRanges} entries (one per study), plus + the LD reference(s) the rows were harmonized against and a single genome + build that applies to the whole collection. Each \code{GRanges} entry must carry per-variant statistics in its mcols (at minimum \code{SNP}, \code{A1}, \code{A2}, \code{Z}, \code{N}; optionally diff --git a/man/LdEigen.Rd b/man/LdEigen.Rd index 3b99a891..ce6aaa4f 100644 --- a/man/LdEigen.Rd +++ b/man/LdEigen.Rd @@ -20,7 +20,8 @@ LdEigen( \item{eigenList}{A list with one entry per LD block.} -\item{ldBlocks}{A \code{GRanges} of LD block intervals.} +\item{ldBlocks}{The LD block intervals: a \code{GRanges}, or the path +of a BED file, read as BED with a 0-based start.} \item{nSamples}{Integer, sample size of the LD reference panel.} diff --git a/man/LdMatrix-class.Rd b/man/LdMatrix-class.Rd index bbcffe7c..2793b216 100644 --- a/man/LdMatrix-class.Rd +++ b/man/LdMatrix-class.Rd @@ -11,6 +11,10 @@ \arguments{ \item{object}{An \code{LdMatrix}.} } +\value{ +\code{show} is called for its side effect and returns + \code{invisible(NULL)}. +} \description{ An \code{LdMatrix} carries one LD correlation matrix together with the variants it describes, and can stand wherever pecotmr takes an diff --git a/man/LdScore.Rd b/man/LdScore.Rd index 500cab4a..835d0392 100644 --- a/man/LdScore.Rd +++ b/man/LdScore.Rd @@ -26,7 +26,8 @@ annotation-stratified scores.} \item{ldScoreWeights}{Numeric regression weights, one per variant.} -\item{ldBlocks}{A \code{GRanges} of LD block intervals.} +\item{ldBlocks}{The LD block intervals: a \code{GRanges}, or the path +of a BED file, read as BED with a 0-based start.} \item{nSamples}{Integer, sample size of the LD reference panel.} diff --git a/man/MethodParam-class.Rd b/man/MethodParam-class.Rd index cbcca80d..d6301777 100644 --- a/man/MethodParam-class.Rd +++ b/man/MethodParam-class.Rd @@ -9,6 +9,7 @@ \alias{names,MethodParam-method} \alias{length,MethodParam-method} \alias{as.list,MethodParam-method} +\alias{$<-,MethodParam-method} \alias{show,MethodParam-method} \title{Typed Settings For One Pipeline Stage} \usage{ @@ -22,6 +23,8 @@ \S4method{as.list}{MethodParam}(x, ...) +\S4method{$}{MethodParam}(x, name) <- value + \S4method{show}{MethodParam}(object) } \arguments{ @@ -36,6 +39,9 @@ set.} \item{...}{Unused, for consistency with the generic.} +\item{value}{The setting's new value; \code{NULL} unsets a setting that +may be unset.} + \item{object}{A \code{MethodParam} object.} } \value{ @@ -50,6 +56,12 @@ set.} \code{as.list} returns the settings that are set, as a named list. +\code{$<-} returns the record rebuilt with that setting replaced. + The rebuild goes through the class's own constructor, so the value is + normalised and checked exactly as it is when the record is built, and a + value the constructor would refuse is refused here too. A setting that + cannot change once the record exists is refused, saying why. + \code{show} is called for its side effect and returns \code{invisible(NULL)}. } @@ -71,8 +83,8 @@ The virtual base of pecotmr's \code{*Param()} records -- \section{List interface}{ A \code{MethodParam} reads like a list: \code{$} and \code{[[} fetch a - field, and \code{names()}, \code{length()} and \code{as.list()} describe - it. + field, \code{$<-} replaces one, and \code{names()}, \code{length()} and + \code{as.list()} describe it. Those last three report only the fields that are \strong{set}. A slot holding \code{NULL} is absent from all three, while \code{$} and diff --git a/man/MultiStudyQtlDataset-class.Rd b/man/MultiStudyQtlDataset-class.Rd index 8befbf2f..9e653309 100644 --- a/man/MultiStudyQtlDataset-class.Rd +++ b/man/MultiStudyQtlDataset-class.Rd @@ -10,6 +10,12 @@ S4 container for a multi-study QTL analysis: a collection of \code{QtlSumStats} collection of summary-statistic-only studies. Used as the input to multi-study fine-mapping and colocboost-style analyses. +It is a \code{\link[S4Vectors]{SimpleList}} of the individual-level +studies, keyed by study name, so \code{length()}, \code{names()}, +\code{[[} and \code{[} address them as on any Bioconductor list; +\code{[} keeps the summary-statistic studies whole and still requires two +studies in total. + At least two studies must be present in total, counting \code{qtlDatasets} entries plus the studies in \code{sumStats}. @@ -22,9 +28,6 @@ re-aligned at construction time. \section{Slots}{ \describe{ -\item{\code{qtlDatasets}}{A named list of \code{QtlDataset} objects, keyed by study -identifier.} - \item{\code{sumStats}}{An optional \code{QtlSumStats} carrying additional summary-statistic-only studies. \code{NULL} when absent.} }} diff --git a/man/PhenotypeFilterParam.Rd b/man/PhenotypeFilterParam.Rd new file mode 100644 index 00000000..e891f2ac --- /dev/null +++ b/man/PhenotypeFilterParam.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/QtlDataset.R +\docType{class} +\name{PhenotypeFilterParam-class} +\alias{PhenotypeFilterParam-class} +\alias{PhenotypeFilterParam} +\title{Phenotype Quality-Control Options} +\usage{ +PhenotypeFilterParam( + naAction = NULL, + outlierAction = NULL, + outlierPvalThreshold = NULL, + outlierArgs = NULL +) +} +\arguments{ +\item{naAction}{How missing phenotype values are handled: \code{"drop"} +the samples with any missing value among the selected traits, +\code{"impute"} each trait's mean, or \code{"keep"} them as they are.} + +\item{outlierAction}{\code{"keep"} or \code{"drop"} samples flagged as +multivariate outliers by a robust (MCD) Mahalanobis distance, computed +on the residualized phenotypes.} + +\item{outlierPvalThreshold}{Two-sided p-value below which a sample is an +outlier. Default \code{1e-3} when unset.} + +\item{outlierArgs}{A \code{\link{CovMcdOptions}} record of extra arguments +for \code{robustbase::covMcd()}, the outlier detector.} +} +\value{ +A \code{PhenotypeFilterParam} object, a \code{\link{MethodParam}}. +} +\description{ +How a run of \code{\link{fineMappingPipeline}}, + \code{\link{twasWeightsPipeline}} or \code{\link{colocboostPipeline}} on + a \code{\link{QtlDataset}} treats the phenotypes it reads: missing + values, and multivariate outlier samples. The phenotype counterpart of + \code{\link{GenotypeFilterParam}}. A \code{QtlDataset}'s own accessors + (\code{\link{molecularTraits}}, \code{\link{residualizedPhenotypes}}) + apply none of it and return the data as stored. +} +\section{Unset fields}{ + + Every field defaults to \code{NULL}, meaning \strong{not set}, and takes + its default when the run resolves the bundle. \code{naAction} resolves + to the pipeline's own policy: fine-mapping and TWAS fits cannot take a + missing phenotype, so they drop the affected samples (and refuse + \code{"keep"}), while colocboost receives the phenotypes as they are. + Outliers are kept unless \code{outlierAction = "drop"}. +} + +\examples{ +PhenotypeFilterParam(naAction = "impute", outlierAction = "drop") +} +\seealso{ +\code{\link{GenotypeFilterParam}} +} diff --git a/man/QtlDataset-class.Rd b/man/QtlDataset-class.Rd index f2773105..e4c51dc7 100644 --- a/man/QtlDataset-class.Rd +++ b/man/QtlDataset-class.Rd @@ -89,37 +89,6 @@ 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{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 -block.} - -\item{\code{scaleResiduals}}{Logical (length 1). Whether residualization accessors -scale residuals to unit variance.} - -\item{\code{mafCutoff}}{Numeric (length 1). Minor allele frequency threshold; -variants with \code{MAF < mafCutoff} are dropped at extraction time inside -\code{genotypes()} / \code{residualizedGenotypes()}. Default 0 (no -filter).} - -\item{\code{macCutoff}}{Numeric (length 1). Minor allele count threshold; converted -to a MAF threshold using \code{max(mafCutoff, macCutoff / (2 * n))} where -\code{n} is the post-narrowing sample count of the extracted block. Default -0 (no filter).} - -\item{\code{xvarCutoff}}{Numeric (length 1). Per-variant genotype variance threshold; -variants with column variance below this are dropped at extraction time. -Default 0 (no filter).} - -\item{\code{imissCutoff}}{Numeric (length 1). Per-sample genotype-missingness -threshold; samples with a missing-genotype rate above this are dropped at -extraction time. Default 0 (no filter).} - -\item{\code{keepVariants}}{Character vector of variant identifiers to retain prior to -per-block QC. Length 0 means no restriction.} - -\item{\code{keepIndel}}{Logical (length 1). When \code{FALSE}, indel variants -(alleles that are not single nucleotides) are dropped at extraction time. -Default \code{TRUE}.} +entries.} }} diff --git a/man/QtlDataset.Rd b/man/QtlDataset.Rd index 3fa67fbd..eb5be46a 100644 --- a/man/QtlDataset.Rd +++ b/man/QtlDataset.Rd @@ -8,9 +8,7 @@ QtlDataset( studyName, genotypes, phenotypes, - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0), - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam() + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) ) } \arguments{ @@ -26,34 +24,6 @@ context. Each SE must have \code{rowRanges} carrying trait positions and \item{genotypeCovariates}{Numeric matrix of genotype-derived covariates (e.g., ancestry PCs); rows are samples. Becomes the \code{colData} of the genotype experiment.} - -\item{scaleResiduals}{Logical (length 1). Default \code{TRUE}.} - -\item{genotypeFilterParam}{Which variants and samples to keep, built with -\code{\link{GenotypeFilterParam}}. A bare list is refused, since it -cannot be checked. Each field is recorded on the object and applied -lazily, at extraction time inside \code{genotypes()} / -\code{residualizedGenotypes()}: -\itemize{ - \item \code{mafCutoff} --- drop variants with - \code{MAF < mafCutoff}. Unset means 0 (no filter). - \item \code{macCutoff} --- a minor-allele-count threshold, converted - to a MAF threshold as \code{max(mafCutoff, macCutoff / (2 * n))} - with \code{n} the post-narrowing sample count of the extracted - block. Unset means 0. - \item \code{xvarCutoff} --- drop variants whose column variance is - below this. Unset means 0. - \item \code{imissCutoff} --- drop samples whose missing-genotype rate - exceeds this. Unset means 0. - \item \code{keepSamples} --- subset the dataset to these samples, - narrowing \code{colData} and \code{sampleMap} together so the - sample set has one home rather than two. Unset, or - \code{character(0)}, means no restriction. - \item \code{keepVariants} --- retain only these variants, before - per-block QC. Unset, or \code{character(0)}, means no restriction. - \item \code{keepIndel} --- when \code{FALSE}, drop variants whose - alleles are not single nucleotides. Unset means \code{TRUE}. -}} } \value{ A \code{QtlDataset} object. @@ -67,6 +37,16 @@ Construct a \code{QtlDataset}: one study's individual-level names actually present in each, so contexts observing different sample subsets are recorded rather than assumed away. } +\details{ +A \code{QtlDataset} holds data only. Which variants and samples + an analysis keeps, and whether residuals are scaled, are the pipeline's + settings (\code{\link{GenotypeFilterParam}} and + \code{\link{ResidualizationParam}} on \code{\link{fineMappingPipeline}}, + \code{\link{twasWeightsPipeline}} and \code{\link{colocboostPipeline}}), + applied per extracted block. To work with part of the data, subset the + dataset itself: \code{x[i, j, k]} narrows features, samples and + contexts. +} \examples{ panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") diff --git a/man/QtlEnrichmentParam.Rd b/man/QtlEnrichmentParam.Rd index 62fa2d13..ee7a1e5b 100644 --- a/man/QtlEnrichmentParam.Rd +++ b/man/QtlEnrichmentParam.Rd @@ -42,7 +42,7 @@ A \code{QtlEnrichmentParam} object, a \code{\link{MethodParam}}. \description{ The algorithmic settings \code{\link{qtlEnrichment}} takes, as one checked bundle. Everything else that function accepts --- the two - data arguments, \code{numThreads}, \code{seed}, \code{verbose}, and the + data arguments, \code{BPPARAM}, \code{seed}, \code{verbose}, and the \code{alignNames} switch --- is the pipeline's own business and is not settable here. } diff --git a/man/QtlFineMappingResult-class.Rd b/man/QtlFineMappingResult-class.Rd index 0e43c044..55b19291 100644 --- a/man/QtlFineMappingResult-class.Rd +++ b/man/QtlFineMappingResult-class.Rd @@ -6,14 +6,16 @@ \title{QTL Fine-Mapping Result Collection} \description{ S4 collection of fine-mapping fits for one or more QTL - studies on a single LD block. Keyed by the identity tuple - \code{(study, context, trait, method)}; each entry is a - \code{FineMappingRow}. + studies, one row per \code{(study, context, trait, method)} fit. Each + element is a fit's variants: a \code{GRanges} on one chromosome whose + \code{mcols} hold the per-variant values \code{\link{topLoci}} reads. -Required columns: \code{study}, \code{context}, \code{trait}, -\code{method}, \code{entry}. The 4-tuple is unique. The caller is -expected to construct one \code{QtlFineMappingResult} per LD block (no -in-class block indexing). +Required \code{mcols()} columns: the identity tuple \code{study}, +\code{context}, \code{trait} and \code{method}, which is unique, and +each row's stored fit \code{susieFit} and cross-validation result +\code{cvResult}. The constructor also records \code{fitVariants}, the +variants each fit was made with. There is no LD-block axis: a trait's fit +is one row wherever its window falls. Optional columns \code{jointStudies}, \code{jointContexts}, \code{jointTraits} appear when the collection contains rows produced by a diff --git a/man/QtlFineMappingResult.Rd b/man/QtlFineMappingResult.Rd index c48c3593..117635cc 100644 --- a/man/QtlFineMappingResult.Rd +++ b/man/QtlFineMappingResult.Rd @@ -18,7 +18,8 @@ QtlFineMappingResult( dataType = NULL, dataSource = NULL, weightStandardized = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) } \arguments{ @@ -61,9 +62,9 @@ derives the window from the span of the variants present.} 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{ldReference} cannot say which row came from which.} +\code{"individual"} or \code{"sumstat"}. Where it is absent, the result +writers read a row's kind from its LD reference: a row with none saw +individual-level data.} \item{weightStandardized}{Optional per-row flag: whether the posterior effect is on the STANDARDIZED genotype scale. The posterior effect IS the @@ -73,24 +74,30 @@ 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{ldReference}{An optional genotype panel (see -\code{\link{readGenotypes}}) (the LD reference for RSS-derived fits), or -\code{NULL} for individual-level fits.} +\item{ldReference}{The LD reference RSS-derived fits were computed +against -- a genotype panel (see \code{\link{readGenotypes}}), a +\code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +a list with one per row; \code{NULL} for individual-level fits. Each +distinct reference is stored once.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ 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{ldReference} slot records the - LD reference used for RSS-derived fits; pass \code{NULL} (the default) for - individual-level fits. +Construct a \code{QtlFineMappingResult} collection from + per-tuple vectors and a list of \code{FineMappingRow} payloads (one per + tuple). The optional \code{ldReference} records the LD + reference each RSS-derived fit used; leave it \code{NULL} (the default) + for individual-level fits. } \examples{ tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), pip = c(0.9, 0.5, 0.1), cs = c(1L, 1L, NA)) -fe <- fineMappingRow( +fe <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl) QtlFineMappingResult(studyName = "s1", context = "brain", trait = "g1", method = "susie", entry = list(fe)) diff --git a/man/QtlSumStats-class.Rd b/man/QtlSumStats-class.Rd index eb172937..c2dfe632 100644 --- a/man/QtlSumStats-class.Rd +++ b/man/QtlSumStats-class.Rd @@ -12,10 +12,21 @@ 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{ldReference}, \code{genome} and - \code{qcInfo} -- apply uniformly to every row, and \code{qcInfo} records - which \code{\link{summaryStatsQc}} passes have run. + the 3-tuple is unique. The constructor also adds each tuple's analysis + window: \code{region}, a \code{GRanges} with one range per element, and + \code{regionGiven}, \code{TRUE} where the window was given as a + \code{region} and \code{FALSE} where it is the span of the tuple's + variants when the collection was first built, before any QC. A QC pass + carries both unchanged; the span of the variants left is + \code{range(x)}. An optional \code{traitPos} gives the trait's own + coordinates, from which a pipeline's \code{cisWindow} derives a cis + window. The class-level slots inherited from + \code{\linkS4class{SumStatsBase}} -- \code{genome} and + \code{qcOptions} -- apply uniformly to every row, and \code{qcOptions} + records the \code{\link{summaryStatsQc}} options that ran (what QC did + to each row is \code{\link{qcInfo}}); \code{ldReference} holds + each distinct LD reference once, and the \code{ldReference} column names + the one each row uses. } \seealso{ \code{\link{QtlSumStats}} for the constructor and diff --git a/man/QtlSumStats.Rd b/man/QtlSumStats.Rd index f817cffd..3240aa33 100644 --- a/man/QtlSumStats.Rd +++ b/man/QtlSumStats.Rd @@ -13,9 +13,11 @@ QtlSumStats( ldReference = NULL, varY = NA_real_, nSample = NULL, - qcInfo = list(), + qcOptions = list(), traitPos = NULL, - extraCols = list() + region = NULL, + extraCols = list(), + metadata = list() ) } \arguments{ @@ -29,12 +31,13 @@ QtlSumStats( 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 reference.} +\code{"hg19"}, \code{"hg38"}). One build per collection.} \item{ldReference}{The LD reference: a genotype panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} or an -\code{\link{LdMatrix}}.} +\code{\link{LdMatrix}}, used for every tuple, or a list with one per +tuple when they sit on different references. Each distinct reference is +stored once, and the \code{ldReference} column names each row's.} \item{varY}{Optional numeric vector of per-tuple phenotype variances (\code{NA_real_} entries allowed).} @@ -47,32 +50,46 @@ no per-variant \code{N} column. Named \code{nSample} to avoid clashing with collections carry no case/control counts (molecular traits are quantitative), so only this total-N fallback is exposed.} -\item{qcInfo}{A \code{list} recording which QC steps ran. Empty \code{list()} -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{qcOptions}{A \code{list} recording the QC that ran. Empty +\code{list()} on construction; \code{summaryStatsQc()} fills it. +Fine-mapping / TWAS pipelines reject inputs where +\code{length(qcOptions(x)) == 0}.} \item{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.} +\code{NULL} (default) omits the column. A pipeline given a +\code{cisWindow} analyses each tuple over \code{traitPos} \eqn{\pm} +\code{cisWindow}.} -\item{extraCols}{Optional named list of additional per-tuple columns to +\item{region}{Optional analysis window of each tuple: a \code{GRanges}, +or the path of a BED file, read as BED with a 0-based start. One window +for every tuple, or one per tuple. A tuple's variants outside its window +are dropped with a warning, and its \code{region} is the window, +recorded as given in \code{regionGiven}. Without it, a tuple's +\code{region} is the span of its variants as built, before any QC.} + +\item{extraCols}{Optional named list (or \code{DataFrame} / +\code{data.frame}) of additional per-tuple columns to attach to the collection's \code{mcols}. Named rather than variadic because the base class's own constructor, \code{GRangesList(...)}, uses \code{...} for its \emph{elements}: a bare \code{...} here would read as adding an entry rather than a metadata column.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ 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 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}, - \code{P}). +Construct a \code{QtlSumStats} S4 collection from per-tuple + vectors and a list of \code{GRanges} entries (one per tuple), plus the LD + reference(s) the rows were harmonized against and a single genome build + that applies 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}, \code{P}). } \examples{ panel <- readGenotypes( diff --git a/man/RaissParam.Rd b/man/RaissParam.Rd index 80ad15a7..2daac830 100644 --- a/man/RaissParam.Rd +++ b/man/RaissParam.Rd @@ -47,7 +47,12 @@ this and \code{mafCutoff} applies. Default \code{0}.} \item{imissCutoff}{Missingness ceiling for a target. Default \code{1}.} \item{flank}{Base pairs by which to widen the analysis-region window on -each side, retaining LD context for edge variants. Default \code{0}.} +each side, retaining LD context for edge variants. The window never +widens into another row of the same study on its chromosome -- the +neighbouring LD block of a block-split GWAS -- since that row imputes +its own variants, nor past a row's block range where that was given +(\code{regionGiven}, see \code{\linkS4class{GwasSumStats}}). Default +\code{0}.} } \value{ A \code{RaissParam} object, a \code{\link{MethodParam}}. diff --git a/man/RangedTupleList-class.Rd b/man/RangedTupleList-class.Rd index a233bbbf..3095b95f 100644 --- a/man/RangedTupleList-class.Rd +++ b/man/RangedTupleList-class.Rd @@ -14,6 +14,22 @@ Virtual base class for pecotmr's per-element collections. Each elements and \code{mcols} together, but leaves slots untouched, so a per-element slot silently ends up the wrong length and positionally wrong. } +\section{Sequence names and genome build}{ + Every range pecotmr holds is on + UCSC sequence names (\code{chr1}, \code{chrX}, \code{chrM}), the style + \code{seqlevelsStyle(x) <- "UCSC"} gives. Ranges read from a file, + placed by variant id, passed to a constructor or given as a range + argument are renamed on the way in (\code{"1"} and \code{"chr1"} both + become \code{chr1}), so ranges from different inputs compare as they + are. A query handed straight to an inherited Bioconductor method, such + as \code{subsetByOverlaps()}, is not renamed: give it in UCSC style. + A pipeline's result carries the genome build its inputs name in + \code{seqinfo()}, as do the ranged views of it (\code{topLoci()}, + \code{colocVariants()}, ...); inputs naming different builds are + refused. When no input names one, \code{genome()} is \code{NA} until it + is set with \code{genome(x) <- "hg38"}. +} + \section{Invariant}{ One seqname and one strand per element. \code{range()} splits on both, so a mixed element would return two ranges and break the diff --git a/man/RangedTupleList-methods.Rd b/man/RangedTupleList-methods.Rd index c20e7fda..319abb1c 100644 --- a/man/RangedTupleList-methods.Rd +++ b/man/RangedTupleList-methods.Rd @@ -7,9 +7,13 @@ \alias{colnames,RangedTupleList-method} \alias{$,RangedTupleList-method} \alias{$<-,RangedTupleList-method} +\alias{elementMetadata<-,RangedTupleList-method} \alias{[,RangedTupleList,ANY,ANY,ANY-method} \alias{[[<-,RangedTupleList,ANY,ANY-method} \alias{endoapply,RangedTupleList-method} +\alias{sort,RangedTupleList-method} +\alias{unique,RangedTupleList-method} +\alias{trim,RangedTupleList-method} \alias{bindROWS,RangedTupleList-method} \title{RangedTupleList methods} \usage{ @@ -23,12 +27,20 @@ \S4method{$}{RangedTupleList}(x, name) <- value +\S4method{elementMetadata}{RangedTupleList}(x, ...) <- value + \S4method{[}{RangedTupleList,ANY,ANY,ANY}(x, i, j, ..., drop = TRUE) \S4method{[[}{RangedTupleList,ANY,ANY}(x, i, j, ...) <- value \S4method{endoapply}{RangedTupleList}(X, FUN, ...) +\S4method{sort}{RangedTupleList}(x, decreasing = FALSE, ...) + +\S4method{unique}{RangedTupleList}(x, incomparables = FALSE, ...) + +\S4method{trim}{RangedTupleList}(x, use.names = TRUE, ...) + \S4method{bindROWS}{RangedTupleList}( x, objects = list(), @@ -44,28 +56,36 @@ \item{name}{An \code{mcols} column name.} -\item{value}{Replacement value for that column.} +\item{value}{For \code{$<-}, the replacement column; for +\code{elementMetadata<-}, the replacement metadata table.} + +\item{...}{Additional arguments passed on.} \item{i}{Element selector.} \item{j}{Not supported; supplying it is an error.} -\item{...}{Additional arguments passed on.} - \item{drop}{Passed through to the inherited method.} \item{FUN}{A function applied to each element, returning a \code{GRanges}.} +\item{decreasing}{Passed to each element's \code{sort()}.} + +\item{incomparables}{Passed to each element's \code{unique()}.} + +\item{use.names}{For \code{trim()}, passed to each element's +\code{trim()}; otherwise unused, present for generic compatibility.} + \item{objects}{Further collections to append, as \code{c()} and \code{append()} pass them.} -\item{use.names, ignore.mcols, check}{Unused; present for generic -compatibility.} +\item{ignore.mcols, check}{Unused; present for generic compatibility.} } \value{ \code{nrow()} and \code{ncol()} integers; \code{colnames()} a - character vector; \code{$} a metadata column; \code{$<-}, \code{[} and - \code{endoapply()} a collection of the same class. + character vector; \code{$} a metadata column; \code{$<-}, + \code{elementMetadata<-}, \code{[}, \code{endoapply()}, \code{sort()}, + \code{unique()} and \code{trim()} a collection of the same class. } \description{ Container and metadata methods shared by every @@ -74,10 +94,18 @@ Container and metadata methods shared by every \code{nrow()} counts elements, \code{ncol()} counts metadata columns and \code{colnames()} names them, so the collections read exactly as the \code{DFrame}-shaped ones they replace. \code{$} and \code{$<-} - read and write \code{mcols} columns. \code{[} selects elements and + read and write \code{mcols} columns. Storing metadata, whether by + \code{$<-}, \code{mcols<-} or its older spellings \code{values<-} and + \code{elementMetadata<-}, refuses an identity column (\code{study}, + \code{context}, \code{trait}, \code{method}, their \code{gwas} + counterparts and \code{blockId}) that is not character; \code{NA} values + are allowed. \code{[} selects elements and \strong{rejects} a second argument, because the stock method would silently discard it. \code{endoapply()} maps over the elements and - rebuilds the object with its collection-level slots intact. + rebuilds the object with its collection-level slots intact; + \code{sort()}, \code{unique()} and \code{trim()} work on each element + the same way, so they too return the collection's own class rather than + a bare \code{GRangesList}. } \examples{ data(qtlSumStatsMulticontextExample) diff --git a/man/ResidualizationParam.Rd b/man/ResidualizationParam.Rd index b07794e7..9c0903ba 100644 --- a/man/ResidualizationParam.Rd +++ b/man/ResidualizationParam.Rd @@ -31,12 +31,10 @@ covariates. \code{NULL} (default) means unset, read as \code{TRUE}.} \item{scaleResiduals}{Logical. Scale each residual column to unit variance, which is what puts a fitted effect on the standardized -genotype scale. \code{NULL} (default) means unset, and the accessors -fall back to the dataset's own \code{\link{scaleResiduals}} slot -(itself \code{TRUE} by default) --- so this is the per-call override of -a per-object default, and the only knob the pipelines need: it reaches -\code{\link{residualizedGenotypes}} already, which is the one point -every individual-level fit draws its genotypes through.} +genotype scale. \code{NULL} (default) means unset, read as +\code{TRUE}. It is the only scale knob the pipelines need: it reaches +\code{\link{residualizedGenotypes}}, the one point every +individual-level fit draws its genotypes through.} \item{covariateNaAction}{How missing covariate values are handled when the design is assembled: \code{"impute"} or \code{"drop"}. \code{NULL} diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index fa0adeb1..7865724b 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{ldReference} / \code{qcInfo} slots, and the genome build in + \code{ldReference} / \code{qcOptions} slots, and the genome build in \code{seqinfo()}. Each element is the per-variant \code{GRanges} of one tuple, so @@ -19,19 +19,21 @@ Virtual base class for QTL and GWAS summary statistics \section{Slots}{ \describe{ -\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 +\item{\code{ldReference}}{A named list of the LD references the rows were +harmonized against and every pipeline reads LD from, each a genotype +panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} +or an \code{\link{LdMatrix}}. Each distinct reference is stored once, and +the \code{ldReference} column of \code{mcols} names the entry each row +uses, so rows can sit on different references. Optional: an LD-free row +(e.g. for mash, which operates across conditions per variant) has +\code{NA} there; 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 -record (filter names, drop counts, liftover target, RAISS settings, etc.). -Fine-mapping and TWAS-weights pipelines reject inputs where -\code{length(qcInfo(x)) == 0L} -- the slot serves as both the gating -flag and the audit trail.} +\item{\code{qcOptions}}{A \code{list} recording the QC that ran over the +collection: the options \code{summaryStatsQc()} was called with and when. +Empty \code{list()} on construction. Pipelines that need QC'd summary +statistics refuse inputs where \code{length(qcOptions(x)) == 0L}. What +QC did to each row is in the \code{qcAudit} column of \code{mcols()}, +read as a table with \code{\link{qcInfo}}.} }} diff --git a/man/TwasWeights-class.Rd b/man/TwasWeights-class.Rd index 575ddc2e..79011866 100644 --- a/man/TwasWeights-class.Rd +++ b/man/TwasWeights-class.Rd @@ -5,14 +5,16 @@ \alias{TwasWeights-class} \title{TWAS Weights Collection} \description{ -S4 collection of TWAS weights keyed by the identity tuple - \code{(study, context, trait, method)}. Each entry is a - \code{TwasWeightsRow} carrying one method's weights for one - trait/context/study. Implements the \code{DFrame}-subclass collection - pattern. +S4 collection of TWAS weights, one row per + \code{(study, context, trait, method)}: one method's weights for one + trait, context and study. Each element is a row's variants: a + \code{GRanges} whose \code{weight} column holds the weights. -Required columns: \code{study}, \code{context}, \code{trait}, \code{method}, -\code{entry}. Each \code{entry} is a \code{TwasWeightsRow}. +Required \code{mcols()} columns: the identity tuple \code{study}, +\code{context}, \code{trait} and \code{method}, and each row's payload: +its stored fits (\code{fits}), \code{cvResult}, \code{standardized} and +\code{dataType}. The constructor also records \code{fitVariants}, the +variants the weights were fitted on. Optional columns \code{jointStudies}, \code{jointContexts}, \code{jointTraits} appear when the collection contains rows produced by a @@ -25,10 +27,24 @@ jointly across the identity-tuple columns and any present joint columns. \section{Slots}{ \describe{ -\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.} +\item{\code{ldReference}}{A named list of the LD references the weights were +derived against, each a genotype panel, a \code{GenotypeMixture} or an +\code{LdMatrix}, stored once apiece; the \code{ldReference} column of +\code{mcols} names the entry each row used (\code{NA} for weights +learned from individual-level data). Used downstream to check that the +rows a pipeline combines share an LD reference.} }} +\section{Narrowed rows}{ + Each row records in its \code{fitVariants} column + the ids of the variants its weights were fitted on (none for a row + without a fit payload). A row narrowed since keeps its fits as they + were, so \code{cvResult()} and \code{methodFits()} warn, with condition + class \code{pecotmrFitCoverage}, when a row holds fewer variants than + they describe. So do the pipelines that read them: + \code{causalInferencePipeline()} when it selects weights by their + cross-validation, and \code{ctwasPipeline()} for rows whose SuSiE fit + renormalizes their weights. The weights themselves are narrowed with + the row and do not warn. +} + diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index e69a9560..0098b51a 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -15,7 +15,8 @@ TwasWeights( jointTraits = NULL, traitPos = NULL, region = NULL, - ldReference = NULL + ldReference = NULL, + metadata = list() ) } \arguments{ @@ -53,19 +54,25 @@ 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{ldReference}{An optional genotype panel (see -\code{\link{readGenotypes}}), or \code{NULL} for individual-level fits.} +\item{ldReference}{The LD reference the weights were derived against -- +a genotype panel (see \code{\link{readGenotypes}}), a +\code{GenotypeMixture} or an \code{LdMatrix} -- used for every row, or +a list with one per row; \code{NULL} for individual-level fits. Each +distinct reference is stored once.} + +\item{metadata}{A list of free-form metadata about the collection, +as \code{metadata()} holds on any Bioconductor vector. Default +\code{list()}.} } \value{ A \code{TwasWeights} object. } \description{ -Construct a \code{TwasWeights} DFrame-subclass collection from - per-tuple vectors and a list of \code{TwasWeightsRow} payloads (one per - tuple). +Construct a \code{TwasWeights} collection from per-tuple + vectors and a list of \code{TwasWeightsRow} payloads (one per tuple). } \examples{ -twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), +twe <- TwasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) tw <- TwasWeights(studyName = "s1", context = "brain", trait = "gene1", diff --git a/man/TwasWeightsRow-class.Rd b/man/TwasWeightsRow-class.Rd index dd800cbc..424ff1b4 100644 --- a/man/TwasWeightsRow-class.Rd +++ b/man/TwasWeightsRow-class.Rd @@ -3,10 +3,11 @@ \docType{class} \name{TwasWeightsRow-class} \alias{TwasWeightsRow-class} +\alias{coerce,TwasWeightsRow,GRanges-method} \title{TWAS Weights Row} \description{ One row's worth of TWAS weights. Build one with - \code{\link{twasWeightsRow}} and pass a list of them as + \code{\link{TwasWeightsRow}} and pass a list of them as \code{\link{TwasWeights}}' \code{entry} argument. } \section{Slots}{ @@ -23,9 +24,20 @@ One row's worth of TWAS weights. Build one with \item{\code{weightStandardized}}{Whether the weights are on the standardized scale.} \item{\code{weightsDataType}}{Optional data-type label.} + +\item{\code{fitVariants}}{The ids of the variants the weights were fitted on, in +the fit's own order, recorded when the row is built; empty for a row with +no fit payload. A row narrowed to fewer variants keeps them, which is how +reading its fits can tell they describe more variants than the row now +holds.} }} +\section{Coercion}{ + \code{as(x, "GRanges")} gives the row's variants with + their \code{weight} column: the element a collection stores for it. +} + \seealso{ -\code{\link{twasWeightsRow}}, +\code{\link{TwasWeightsRow}}, \code{\linkS4class{FineMappingRow}} } diff --git a/man/twasWeightsRow.Rd b/man/TwasWeightsRow.Rd similarity index 91% rename from man/twasWeightsRow.Rd rename to man/TwasWeightsRow.Rd index f552e8f9..2e27d197 100644 --- a/man/twasWeightsRow.Rd +++ b/man/TwasWeightsRow.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/twasWeightsRow.R -\name{twasWeightsRow} -\alias{twasWeightsRow} +\name{TwasWeightsRow} +\alias{TwasWeightsRow} \title{Build One TWAS-Weight Row} \usage{ -twasWeightsRow( +TwasWeightsRow( variantIds, weights, methodFits = NULL, @@ -38,7 +38,7 @@ Assemble a single row's payload for payload. Pass a list of these as the collection's \code{entry} argument. } \examples{ -row <- twasWeightsRow( +row <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:C:T"), weights = c(0.4, -0.2) ) @@ -48,5 +48,5 @@ TwasWeights( ) } \seealso{ -\code{\link{fineMappingRow}} +\code{\link{FineMappingRow}} } diff --git a/man/af.Rd b/man/af.Rd index 0bd8a582..3ebe5b6c 100644 --- a/man/af.Rd +++ b/man/af.Rd @@ -12,23 +12,15 @@ af(x, ...) \S4method{af}{LdMatrix}(x, ...) -\S4method{af}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{af}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) -\S4method{af}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) +\S4method{af}{QtlDataset}(x) } \arguments{ \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}).} +\item{...}{Class-specific selection arguments.} \item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} @@ -38,25 +30,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} - -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier -to select; \code{NULL} matches all traits in the dataset.} - -\item{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.} - -\item{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window -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.} } \value{ Named numeric vector of effect-allele frequencies (names are variant @@ -72,7 +45,8 @@ Extract the directional effect-allele (A1) frequency vector \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. + for supplying one afterwards. A \code{QtlDataset} answers over the whole + dataset; narrow it first, with \code{x[i, j, ]}, to read part of it. } \examples{ data(qtlDatasetExample) diff --git a/man/annotData.Rd b/man/annotData.Rd index 26e13383..9752b959 100644 --- a/man/annotData.Rd +++ b/man/annotData.Rd @@ -13,7 +13,7 @@ annotData(x) \item{x}{An \code{\link{SldscData}} object.} } \value{ -A \code{data.frame} of annotations (CHR, SNP, annotation columns). +A \code{DataFrame} of annotations (CHR, SNP, annotation columns). } \description{ Get the annotation table from an SldscData diff --git a/man/as.data.frame-ColocBoostResult-method.Rd b/man/as.data.frame-ColocBoostResult-method.Rd deleted file mode 100644 index caef690b..00000000 --- a/man/as.data.frame-ColocBoostResult-method.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ColocBoostResult.R -\name{as.data.frame,ColocBoostResult-method} -\alias{as.data.frame,ColocBoostResult-method} -\title{Coerce a ColocBoostResult to a data frame} -\usage{ -\S4method{as.data.frame}{ColocBoostResult}(x, row.names = NULL, optional = FALSE, ...) -} -\arguments{ -\item{x}{A \code{ColocBoostResult}.} - -\item{row.names, optional}{Ignored; present for generic compatibility.} - -\item{...}{Ignored.} -} -\value{ -A data frame with one row per confidence set. -} -\description{ -Returns the set-level view. New code should call the view it - wants (\code{\link{colocViews}}, - \code{\link{colocBoostOutcomes}}). -} -\examples{ -methods::existsMethod("as.data.frame", "ColocBoostResult") -} diff --git a/man/as.data.frame-ColocResult-method.Rd b/man/as.data.frame-ColocResult-method.Rd deleted file mode 100644 index 86f8242a..00000000 --- a/man/as.data.frame-ColocResult-method.Rd +++ /dev/null @@ -1,40 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ColocResult.R -\name{as.data.frame,ColocResult-method} -\alias{as.data.frame,ColocResult-method} -\title{Coerce a ColocResult to a data frame} -\usage{ -\S4method{as.data.frame}{ColocResult}(x, row.names = NULL, optional = FALSE, ...) -} -\arguments{ -\item{x}{A \code{ColocResult}.} - -\item{row.names, optional}{Ignored; present for generic compatibility.} - -\item{...}{Ignored.} -} -\value{ -A data frame with one row per tested pair. -} -\description{ -Returns the pair-level view, which is the flat table - \code{colocPipeline()} used to return directly. Provided so existing - consumers keep working; new code should call the view it actually wants - (see \code{\link{colocViews}}). -} -\examples{ -pairs <- data.frame( - study = "s1", context = "c1", trait = "g1", method = "susie", - gwasStudy = "G1", gwasContext = NA_character_, - gwasTrait = NA_character_, gwasMethod = "susie", - blockId = "chr1_1_1000", - qtlCs = 1L, gwasCs = 1L, nSnps = 2L, - PP.H0.abf = 0.1, PP.H1.abf = 0.1, PP.H2.abf = 0.1, - PP.H3.abf = 0.1, PP.H4.abf = 0.6 -) -variants <- list(data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - SNP.PP.H4 = c(0.7, 0.3) -)) -as.data.frame(ColocResult(pairs, variants)) -} diff --git a/man/asGranges.Rd b/man/asGranges.Rd deleted file mode 100644 index d06d8fa5..00000000 --- a/man/asGranges.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{asGranges} -\alias{asGranges} -\title{Convert region specifications to a GRanges object} -\usage{ -asGranges(regions) -} -\arguments{ -\item{regions}{A region string, character vector, or data.frame with -chrom/start/end columns.} -} -\value{ -A \code{GRanges} object. -} -\description{ -Accepts region strings ("chr1:100-200", "1_100_200"), character vectors of -such strings, or data.frames with chrom/start/end columns. Returns a -\code{\link[GenomicRanges]{GRanges}} object. -} -\examples{ -regions <- c("chr1:100-200", "chr1:300-400") -asGranges(regions = regions) -} diff --git a/man/assembleCtwasInputs.Rd b/man/assembleCtwasInputs.Rd index b871e86a..a1714c58 100644 --- a/man/assembleCtwasInputs.Rd +++ b/man/assembleCtwasInputs.Rd @@ -9,6 +9,7 @@ assembleCtwasInputs( twasWeights, twasZ = NULL, fineMappingResult = NULL, + fineMappingMethod = NULL, method = NULL, variantPruningParam = VariantPruningParam() ) @@ -16,8 +17,8 @@ assembleCtwasInputs( \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} whose elements are LD blocks (at least two), keyed by its \code{blockId} column, with -\code{qcInfo()} non-empty. Build it with -\code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it +\code{qcOptions()} non-empty. Build it with +\code{loadGwasSumStatsFromManifest(..., region = )} and pass it through \code{\link{summaryStatsQc}}.} \item{twasWeights}{The per-gene weight source. Either (a) a FLAT @@ -31,27 +32,38 @@ ctwas's joint group prior estimate (the legacy whole-chromosome pattern where only a few of many LD blocks carry gene weights). A gene whose cis span straddles a block boundary is homed by its single anchor; the cross-block signal is cTWAS's boundary-gene concern -(\code{\link{mergeCtwasBoundaryRegions}}), not placement.} +(\code{\link{mergeCtwasBoundaryRegions}}), not placement. A +\code{TwasWeights} row of the run's method that carries a SuSiE fit and +was narrowed since that fit warns (condition class +\code{pecotmrFitCoverage}): the fit no longer lines up with the row's +variants, so its weights are not renormalized over the variants kept.} \item{twasZ}{Optional \code{GRanges} of TWAS Z-scores (output of \code{\link{causalInferencePipeline}}). When supplied, the per-(trait, context) Z is used as the \code{z_gene} input to \code{ctwas_sumstats} so it is not recomputed.} -\item{fineMappingResult}{Optional \code{QtlFineMappingResult} or -\code{GwasFineMappingResult} carrying the per-variant PIP and credible-set -membership data used by the CS / PIP rescue filters (\code{csMinCor} and -\code{minPipCutoff}). When \code{NULL} (default) the smart filters are -no-ops; only the magnitude filter (\code{twasWeightCutoff}) and the -per-gene cap (\code{maxNumVariants}, ordered by \code{|weight|}) apply.} +\item{fineMappingResult}{Optional \code{QtlFineMappingResult}: the genes' +own fine-mapping, whose per-variant PIP and credible-set membership the +CS / PIP rescue filters (\code{csMinCor} and \code{minPipCutoff}) read. +Each gene is looked up by its weights' \code{(study, context, trait)} in +the fits of \code{fineMappingMethod}; a gene with no fit there gets no +rescue. When \code{NULL} (default) the smart filters are no-ops; only the +magnitude filter (\code{twasWeightCutoff}) and the per-gene cap +(\code{maxNumVariants}, ordered by \code{|weight|}) apply.} -\item{method}{Optional character (length 1). Picks which TWAS method's -weights to feed into ctwas for each (study, context, trait) gene. When -\code{NULL} (default): use \code{"ensemble"} if that method is present -across the weight sources; otherwise use the sole method when only one is -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{fineMappingMethod}{Character (length 1): the method of +\code{fineMappingResult} whose fits the rescues read, e.g. +\code{"susie"}. Required with a \code{fineMappingResult}, since the +weights' own method -- an \code{"ensemble"} or \code{"lasso"} weight -- +names no fine-mapping fit. Default \code{NULL}.} + +\item{method}{Character (length 1): which TWAS method's weights to feed +into ctwas for each (study, context, trait) gene, one method per run. +\code{NULL} (default) uses the pre-combined \code{"ensemble"} weights of +\code{TwasWeights}. Weights with no ensemble, and fine-mapping results as +the weight source, have no default: name the method (e.g. +\code{"mrash"}, or a fine-mapping method such as \code{"susie"}).} \item{variantPruningParam}{Which variants survive into each gene's weight matrix, built with \code{\link{VariantPruningParam}}: @@ -92,10 +104,9 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldReference = ldStem, region = "chr22:10000000-19000000", - ldBlocks = blocks) + ldReference = ldStem, which = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) assembleCtwasInputs(gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample)) + twasWeights = list(ctwasWeightsExample), method = "susie") } diff --git a/man/autoDecision.Rd b/man/autoDecision.Rd index e71547d4..a759ca74 100644 --- a/man/autoDecision.Rd +++ b/man/autoDecision.Rd @@ -11,7 +11,12 @@ autoDecision(df, highCorrCols) study and block.} \item{highCorrCols}{Character vector. Names of columns in df that represent -high correlations.} +high correlations; a non-top CS whose value in any of them is 1 is +tagged. A CS's own column of \code{\link{extractCsInfo}}'s between-CS +correlations (\code{cs_corr_} for row \code{i}, its self-correlation) +is never read, so passing every \code{cs_corr_*} column tags a CS only by +its correlation with the other sets. Rows are taken in +\code{extractCsInfo()}'s order.} } \value{ A modified data frame with additional columns attached to the diff --git a/man/blockId.Rd b/man/blockId.Rd index a6d53181..73da3b50 100644 --- a/man/blockId.Rd +++ b/man/blockId.Rd @@ -29,11 +29,13 @@ Return the LD-block identifier of each row of a collection on, so the returned vector is always the same length as \code{nrow(x)} and can be used to label or join rows directly. - It keys the external block manifest the blocks were defined in, and so - carries the true block BOUNDARIES --- unlike \code{range(x)}, which is - the span of the variants that survived QC. A collection with no block - axis (every QTL flavour) returns \code{NA} for every row rather than - erroring, so code that handles both flavours needs no class test. + It keys the external block manifest the blocks were defined in. The + block's BOUNDARIES are the \code{region} column, recorded as given or + computed in \code{regionGiven} (see \code{\linkS4class{GwasSumStats}}) + --- unlike \code{range(x)}, which is the span of the variants that + survived QC. A collection with no block axis (every QTL flavour) + returns \code{NA} for every row rather than erroring, so code that + handles both flavours needs no class test. } \examples{ data(gwasFineMappingExample, qtlFineMappingExample) diff --git a/man/buildLdEigen.Rd b/man/buildLdEigen.Rd index 81797552..280b6d26 100644 --- a/man/buildLdEigen.Rd +++ b/man/buildLdEigen.Rd @@ -26,8 +26,8 @@ buildLdEigen( least two blocks and wants many more.} \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 +\code{GRanges}, or the path of a BED file, read as BED with a 0-based +start. 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.} @@ -63,8 +63,8 @@ Eigendecompose an LD reference, block by block, into the 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)) +blocks <- GenomicRanges::GRanges("chr22", + IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000))) ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") ldEigen length(eigenList(ldEigen)) diff --git a/man/buildLdScore.Rd b/man/buildLdScore.Rd index 44a83dcc..e779235b 100644 --- a/man/buildLdScore.Rd +++ b/man/buildLdScore.Rd @@ -27,8 +27,8 @@ buildLdScore( least two blocks and wants many more.} \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 +\code{GRanges}, or the path of a BED file, read as BED with a 0-based +start. 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.} @@ -78,8 +78,8 @@ Compute per-variant LD scores from an LD reference, block by 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)) +blocks <- GenomicRanges::GRanges("chr22", + IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000))) ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") ldScore head(S4Vectors::mcols(ldScore)$ldScores) diff --git a/man/buildMvsusieMixturePrior.Rd b/man/buildMvsusieMixturePrior.Rd index e40e6e84..63241fbb 100644 --- a/man/buildMvsusieMixturePrior.Rd +++ b/man/buildMvsusieMixturePrior.Rd @@ -57,8 +57,6 @@ mr.mash covariances --- or leave it NULL for the canonical uniform mixture over \code{R} conditions. } \examples{ -\donttest{ # Canonical uniform mixture over two named conditions. buildMvsusieMixturePrior(conditionNames = c("brain", "blood")) } -} diff --git a/man/buildTopLoci.Rd b/man/buildTopLoci.Rd index dc14089b..0fd4432c 100644 --- a/man/buildTopLoci.Rd +++ b/man/buildTopLoci.Rd @@ -56,7 +56,8 @@ carries no sample count: \code{n} is left \code{NA} for the per-variant \item{otherQuantities}{Optional list. Default is NULL.} -\item{region}{Optional \code{"chr:start-end"} string. Default is NULL.} +\item{region}{Optional \code{GRanges}: the window the fit covers, whose +bounds the table records. Default is NULL.} \item{conditionIdx}{Integer or \code{NULL}. Index of the conditioned effect (per-condition output); \code{NULL} for the unconditioned fit.} diff --git a/man/causalInferencePipeline.Rd b/man/causalInferencePipeline.Rd index 6deb488c..276e9471 100644 --- a/man/causalInferencePipeline.Rd +++ b/man/causalInferencePipeline.Rd @@ -16,7 +16,14 @@ causalInferencePipeline( } \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} object. Must be QC'd -(\code{length(qcInfo(x)) > 0L}).} +(\code{length(qcOptions(x)) > 0L}). A study may span many rows (one per +chromosome or LD block); each QTL tuple is scored once per study, over the +statistics of the rows its window overlaps. A tuple's variants outside +every loaded block of a study it overlaps are an error where the blocks' +ranges were given (\code{regionGiven}, see +\code{\linkS4class{GwasSumStats}}), since they lie in a block that was not +loaded, and a warning for more than one in a row past a range computed +from the GWAS variants.} \item{twasWeights}{Optional \code{\link{TwasWeights}} carrying per-(study, context, trait, method) weights. When supplied, drives the TWAS-Z @@ -37,7 +44,9 @@ Selection runs when \code{cutoff > 0} or \code{pvalCutoff} is finite; it keeps the highest-\code{metric} method among those clearing both 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}.} +\code{pick_best_model} / \code{update_twas_method}. The metrics describe +each fit on all of its variants, so selection warns about a row narrowed +since its fit (condition class \code{pecotmrFitCoverage}).} \item{mrParam}{How Mendelian randomization is run, built with \code{\link{MrParam}}: \code{method} (\code{"ivwPerVariant"}, the @@ -57,7 +66,9 @@ effect / weight sign-flipped accordingly; when FALSE, match on exact alleles only, so a ref/alt swap is treated as a distinct variant.} } \value{ -A \code{GRanges} as described above. +A \code{GRanges} as described above, its \code{seqinfo()} naming + the genome build the inputs name (inputs naming different builds are + refused). } \description{ Per-region pipeline that pairs QTL-derived weight vectors @@ -78,10 +89,13 @@ Per-region pipeline that pairs QTL-derived weight vectors } } \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}. + Per pair of rows scored + together: a QTL input row (TwasWeights or QtlFineMappingResult) that + carries an \code{ldReference} must be the same LD reference as the + \code{gwasSumStats} rows its region overlaps, and the rows of one GWAS + study that a QTL tuple overlaps must share one reference, since its TWAS + z reads one LD matrix. Rows that are never scored together may sit on + different references. 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 @@ -89,8 +103,8 @@ Per-region pipeline that pairs QTL-derived weight vectors 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. + QTL input row with no reference (the fit was learned from + individual-level data) skips the validation. } \section{Output shape}{ diff --git a/man/chromPaths.Rd b/man/chromPaths.Rd index 5f1e495d..360d4cc9 100644 --- a/man/chromPaths.Rd +++ b/man/chromPaths.Rd @@ -15,8 +15,8 @@ chromPaths(x, ...) \item{...}{Additional arguments passed on to methods.} } \value{ -A named character vector mapping canonical chromosome to path or - prefix, possibly empty. +A named character vector mapping each chromosome, in UCSC style + (\code{"chr21"}), to its path or prefix, possibly empty. } \description{ The chromosome-to-path map of a sharded diff --git a/man/coef-methods.Rd b/man/coef-methods.Rd index c4f1b14d..e7213691 100644 --- a/man/coef-methods.Rd +++ b/man/coef-methods.Rd @@ -7,15 +7,7 @@ \usage{ coef(object, ...) -\S4method{coef}{SumStatsBase}( - object, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL, - ... -) +\S4method{coef}{SumStatsBase}(object, studyName = NULL, context = NULL, trait = NULL, ...) } \arguments{ \item{object}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -30,12 +22,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of effect sizes, or \code{NULL} if not available. diff --git a/man/colocBoostOutcomes.Rd b/man/colocBoostOutcomes.Rd index c7d857d0..e8108642 100644 --- a/man/colocBoostOutcomes.Rd +++ b/man/colocBoostOutcomes.Rd @@ -15,9 +15,12 @@ colocBoostOutcomes(x, ...) \item{...}{Ignored.} } \value{ -A tibble with one row per (set, outcome) and the set-level columns - repeated, plus \code{outcome}, \code{study}, \code{context}, - \code{trait} and \code{dataForm}. +A \code{DataFrame} with one row per (set, outcome), the + set-level columns repeated, plus \code{outcome}, \code{study}, + \code{context}, + \code{trait}, \code{dataForm} and \code{ldReference} (the name of the + \code{\link{ldReference}} entry the outcome's summary statistics were + matched against). } \description{ One row per (confidence set, colocalized outcome), joined to diff --git a/man/colocPipeline.Rd b/man/colocPipeline.Rd index 340c58b6..1e024b6d 100644 --- a/man/colocPipeline.Rd +++ b/man/colocPipeline.Rd @@ -58,14 +58,16 @@ two different things.} \item{returnGwasFineMapping}{Logical. When \code{TRUE}, attach the fine-mapping result computed from \code{gwasInput} on the returned object -as attribute \code{"gwasFineMapping"}. Default \code{FALSE}.} +as attribute \code{"gwasFineMapping"}: for a \code{GwasSumStats}, one fit +per set of rows a first-side region reaches. Default \code{FALSE}.} \item{enrichment}{Optional data.frame of per-pair enrichment factors with columns \code{gwasStudy}, \code{qtlStudy}, \code{qtlContext}, \code{enrichment}, and optionally \code{gwasContext} / \code{gwasTrait} -(which the join uses when present, and which -\code{\link{qtlEnrichmentPipeline}} emits for a QTL outcome side). Output -of \code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is +/ \code{gwasMethod} / \code{qtlMethod} (which the join uses when +present; \code{\link{qtlEnrichmentPipeline}} emits all four, the context +and trait set for a QTL outcome side). Output of +\code{\link{qtlEnrichmentPipeline}}. When non-\code{NULL} the pair is scored by enloc rather than coloc: the priors come from that table's \code{colocP1} / \code{colocP2} / \code{colocP12} columns, and the report gains \code{RCP} and \code{LCP}. Pairs without a matching @@ -80,7 +82,9 @@ enrichment row fall back to the baseline priors with a warning. Default missing variants in the GWAS \code{SumStats} and the QTL fine-mapping input has additional variants; (2) the GWAS fine-mapping result contains variants not present in the QTL fine-mapping result. Pass \code{FALSE} to - use the FMRs as supplied. + use the FMRs as supplied; each fit is then scored whole, so a row + narrowed since its fit warns (condition class + \code{pecotmrFitCoverage}). How much of each effect's posterior survived that restriction is reported per result row as \code{qtlRetainedMass} / \code{gwasRetainedMass}; a low @@ -101,7 +105,7 @@ enrichment adjustment reads them too.} } \value{ A \code{\linkS4class{ColocResult}}: one element per tested - (first-side credible set, second-side credible set, block) pair, holding + (first-side credible set, second-side credible set) pair, holding that pair's aligned variants with their \code{SNP.PP.H4}. Pair-level metadata carries the identity columns (\code{study}, \code{context}, \code{trait}, \code{method}, \code{gwasStudy}, \code{gwasContext}, @@ -120,9 +124,10 @@ A \code{\linkS4class{ColocResult}}: one element per tested is what readers of enloc output expect to find. Project it with \code{\link{colocPairs}} (the flat table this - pipeline used to return, also available as \code{as.data.frame}), - \code{\link{colocVariants}}, \code{\link{colocCredibleSets}} or - \code{\link{colocGenes}}. + pipeline used to return), \code{\link{colocVariants}}, + \code{\link{colocCredibleSets}} or \code{\link{colocGenes}}. Its + \code{seqinfo()} names the genome build the two sides name; sides + naming different builds are refused. } \description{ Per-region pipeline that pairs two fine-mapping result @@ -178,10 +183,43 @@ This pipeline preserves all three. } } +\section{A region over several LD blocks}{ + Each first-side region is + colocalized with ONE fit per second-side study and method, however many + of a GWAS study's LD blocks it reaches -- scoring it against each block + separately would split one region into as many colocalizations as it + has blocks, each truncating the region's effects to one block's + variants. + \itemize{ + \item A \code{GwasSumStats} is fine-mapped once per set of rows a + region reaches, their statistics stitched together on their one + LD reference (rows on different references are refused). A + region inside one block reads that block's fit. + \item A \code{GwasFineMappingResult} was fine-mapped block by block. + Assuming no LD between blocks, the blocks a region reaches + collapse into one fit: every block's effects, each confined to + its own block (a Bayes factor of zero elsewhere), numbered on + from the blocks before it in row order. + } + The fit's \code{blockId} is then the stretch the blocks' ranges cover, + as \code{"chrom_start_end"} (see \code{region} in + \code{\linkS4class{GwasSumStats}}). + + A region's variants that lie outside every loaded block of a GWAS + study it overlaps are left out of that fit, a sign that a block it + reaches was not loaded. Where those blocks' ranges were given + (\code{regionGiven}), the variants lie in a block that was not loaded, + and that is an error. Where the ranges are the span of the GWAS + variants, the variants may only be ones the GWAS lacks, so more than one + in a row past a block is a warning. +} + \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}. + Rows can sit on different LD + references, so the check is per pair of rows coloc scores against each + other -- a QTL row and a GWAS row whose regions overlap. Where the QTL + row carries a reference, it must be the same LD reference as the GWAS + row's; rows that are never paired may differ. 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 @@ -190,9 +228,9 @@ This pipeline preserves all three. 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. + any of those, is a hard error. When a first-side row has no reference + (individual-level fit), the validation is skipped for it and the second + side's panel is what the result carries forward for its pairs. } \examples{ diff --git a/man/colocViews.Rd b/man/colocViews.Rd index f727020a..2a56d54d 100644 --- a/man/colocViews.Rd +++ b/man/colocViews.Rd @@ -5,19 +5,24 @@ \alias{colocViews} \alias{colocPairs} \alias{colocVariants} +\alias{colocPooledVariants} \alias{colocCredibleSets} \alias{colocGenes} \alias{colocPairs,ColocResult-method} \alias{colocVariants,ColocResult-method} +\alias{colocPooledVariants,ColocResult-method} \alias{colocGenes,ColocResult-method} \alias{colocCredibleSets,ColocResult-method} \alias{colocPairs,ColocBoostResult-method} \alias{colocVariants,ColocBoostResult-method} +\alias{colocPooledVariants,ColocBoostResult-method} \title{Colocalization Views} \usage{ colocPairs(x, ...) -colocVariants(x, pooled = FALSE, ...) +colocVariants(x, ...) + +colocPooledVariants(x, ...) colocCredibleSets(x, coverage = 0.95, minPp4 = NULL, minAbsCorr = 0.8, ...) @@ -25,7 +30,9 @@ colocGenes(x, ...) \S4method{colocPairs}{ColocResult}(x) -\S4method{colocVariants}{ColocResult}(x, pooled = FALSE) +\S4method{colocVariants}{ColocResult}(x) + +\S4method{colocPooledVariants}{ColocResult}(x) \S4method{colocGenes}{ColocResult}(x) @@ -39,16 +46,15 @@ colocGenes(x, ...) \S4method{colocPairs}{ColocBoostResult}(x) -\S4method{colocVariants}{ColocBoostResult}(x, pooled = FALSE) +\S4method{colocVariants}{ColocBoostResult}(x) + +\S4method{colocPooledVariants}{ColocBoostResult}(x) } \arguments{ \item{x}{A \code{ColocResult}.} \item{...}{Additional arguments passed on to methods.} -\item{pooled}{Logical. \code{colocVariants()} only: pool to one row per -(gene, variant) instead of per (pair, variant).} - \item{coverage}{Cumulative \code{SNP.PP.H4} the credible set must reach.} \item{minPp4}{Optional lower bound on the pair's \code{PP.H4.abf}. Applied @@ -64,10 +70,13 @@ the five posterior probabilities, i.e. colocalization is the favoured hypothesis rather than merely a probable one.} } \value{ -A tibble at the requested granularity. +\code{colocVariants()} and \code{colocPooledVariants()} a + \code{GRanges}, its columns in \code{mcols()}; + \code{colocCredibleSets()} a \code{GRangesList}, one element per set; + the other views a \code{DataFrame}. } \description{ -The four views over a \code{\linkS4class{ColocResult}}. The +The five views over a \code{\linkS4class{ColocResult}}. The object stores one element per tested (QTL credible set, GWAS credible set, block) pair; these accessors project it to the granularity a given analysis needs, rather than any one of them being the stored shape. @@ -77,13 +86,19 @@ The four views over a \code{\linkS4class{ColocResult}}. The \code{$summary} granularity. Every testable pair is reported verbatim, including both halves of a credible set that straddles a block boundary; interpreting them is the caller's decision.} - \item{\code{colocVariants()}}{One row per (pair, variant), carrying + \item{\code{colocVariants()}}{One range per (pair, variant), carrying \code{colocPp = PP.H4.abf * SNP.PP.H4} -- the posterior that this - variant is the shared causal one. With \code{pooled = TRUE}, one row - per (gene, variant) pooled by the rule below.} - \item{\code{colocCredibleSets()}}{One row per coloc credible set: the - smallest set of variants whose cumulative \code{SNP.PP.H4} reaches - \code{coverage}. This is a THIRD variant set, not guaranteed to be a + variant is the shared causal one.} + \item{\code{colocPooledVariants()}}{One range per (gene, variant), + pooled across pairs by the rule below. A + \code{\linkS4class{ColocBoostResult}} pools per (analysis, variant) + instead, with the noisy-OR stage only.} + \item{\code{colocCredibleSets()}}{One element per coloc credible set: + the smallest set of variants whose cumulative \code{SNP.PP.H4} + reaches \code{coverage}, as ranges carrying their \code{SNP.PP.H4}, + with the set's pair columns, \code{csSize}, \code{csCoverage}, + \code{leadVariant}, \code{leadPp} and \code{purity} in + \code{mcols()}. This is a THIRD variant set, not guaranteed to be a subset of either input credible set, so its purity is recomputed from LD rather than inherited.} \item{\code{colocGenes()}}{One row per gene, pooled across pairs.} @@ -108,6 +123,7 @@ res <- colocPipeline( ) head(colocPairs(res)) head(colocVariants(res)) +head(colocPooledVariants(res)) colocGenes(res) head(colocCredibleSets(res, minPp4 = 0.001)) } diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index f8982ed0..530f185a 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -16,7 +16,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) traitId = NULL, region = NULL, cisWindow = NULL, - focalTrait = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -24,6 +24,8 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) panelFilterParam = PanelFilterParam(), signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, + genotypeFilterParam = GenotypeFilterParam(), + phenotypeFilterParam = PhenotypeFilterParam(), residualizationParam = ResidualizationParam(), methodArgs = ColocboostOptions() ) @@ -33,7 +35,8 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) gwasSumStats = NULL, contexts = NULL, traitId = NULL, - focalTrait = NULL, + cisWindow = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -49,7 +52,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) traitId = NULL, region = NULL, cisWindow = NULL, - focalTrait = NULL, + focalOutcome = NULL, xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, @@ -57,6 +60,8 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) panelFilterParam = PanelFilterParam(), signalScreenParam = SignalScreenParam(), alleleFlip = TRUE, + genotypeFilterParam = GenotypeFilterParam(), + phenotypeFilterParam = PhenotypeFilterParam(), residualizationParam = ResidualizationParam(), methodArgs = ColocboostOptions() ) @@ -66,36 +71,59 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) \code{MultiStudyQtlDataset}.} \item{gwasSumStats}{Optional \code{GwasSumStats} with the GWAS studies to -colocalize against. \code{NULL} to skip GWAS colocalization.} +colocalize against. \code{NULL} to skip GWAS colocalization. Each study +is one outcome: the union of its rows that the QTL data overlap, so a +study split by chromosome or LD block contributes just the one or two +rows the QTL region reaches, and a study none of whose rows it reaches is +left out. QTL variants outside every loaded block of a study the QTL data +overlap are an error where the blocks' ranges were given +(\code{regionGiven}, see \code{\linkS4class{GwasSumStats}}), since they +lie in a block that was not loaded, and a warning for more than one in a +row past a range computed from the GWAS variants. Those rows must share +one LD reference, but it need not be the +QTL side's: every outcome's summary statistics are matched against their +own reference. When some references are genotype panels and others are +\code{LdMatrix} objects, the runs that combine them pass colocboost the +panels' LD as matrices, since colocboost takes LD matrices or reference +genotypes but not both.} \item{...}{Required by the generic; the methods take no further arguments.} -\item{contexts}{Optional character vector of context names to restrict the -individual-level / QtlSumStats QTL analysis to. When \code{NULL} (default), -every context present is used.} +\item{contexts}{Optional character vector of context names to restrict +the individual-level / QtlSumStats QTL analysis to. When \code{NULL} +(default), every context present is used. A MultiStudyQtlDataset applies +it to every study: a context no study has is an error, and one only some +studies lack is skipped for those, with a warning.} -\item{traitId}{Optional character vector of trait identifiers to restrict the -analysis to. When supplied with an individual-level \code{QtlDataset} -input, \code{cisWindow} is required (passed to -\code{residualizedGenotypes} / \code{molecularTraits} for the -variant-window selection).} +\item{traitId}{Optional character vector of trait identifiers to restrict +the analysis to. When supplied with an individual-level +\code{QtlDataset} input, \code{cisWindow} is required: each trait's +position \eqn{\pm} \code{cisWindow} is the variant window. In a +MultiStudyQtlDataset a study carrying none of them sits out; the run is +refused only when no study or summary-statistics row carries one.} \item{region}{Optional single-range \code{GRanges} describing the analysis -window. Mutually exclusive with \code{traitId} (see the \code{QtlDataset} -accessors). Individual-level input only: summary statistics carry no -genotypes to window, so the \code{QtlSumStats} method does not take it ---- matching \code{\link{fineMappingPipeline}} and -\code{\link{twasWeightsPipeline}}.} - -\item{cisWindow}{Optional cis window in basepairs; required with -\code{traitId}, optional with \code{region}. Individual-level input -only, as for \code{region}.} - -\item{focalTrait}{Optional trait name; when supplied and present in the -assembled outcome list, the colocboost xQTL-only run uses it as the focal -outcome. Only \code{xqtlColoc} reads it: \code{jointGwas} is -non-focal by construction and \code{separateGwas} always makes the -GWAS study focal.} +window. Mutually exclusive with \code{traitId}. Individual-level input +only: a summary-statistics tuple +keeps the window it was built with (its \code{region}), so the +\code{QtlSumStats} method does not take one --- matching +\code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}.} + +\item{cisWindow}{Optional cis window in basepairs. Individual-level +input: required with \code{traitId}, optional with \code{region}. +QtlSumStats input: each selected tuple is analysed over its +\code{traitPos} \eqn{\pm} \code{cisWindow}, within its \code{region}; +every selected tuple needs a \code{traitPos}. A MultiStudyQtlDataset +applies it to both kinds of study it holds.} + +\item{focalOutcome}{The QTL outcome the \code{xqtlColoc} run treats as +focal (colocboost's \code{focal_outcome_idx}): a named character vector +with any of \code{study}, \code{context} and \code{trait} that +identifies exactly one QTL outcome, e.g. +\code{c(context = "brain", trait = "ENSG1")}. \code{NULL} (default) runs +it non-focal. It needs \code{xqtlColoc = TRUE}: the \code{jointGwas} run +is never focal, and each \code{separateGwas} run is focal on its own +GWAS study.} \item{xqtlColoc, jointGwas, separateGwas}{Logical flags selecting which colocboost variants to run.} @@ -107,8 +135,8 @@ analysis to; \code{NULL} (default) uses all samples.} summary-statistic sides against the LD reference panel, built with \code{\link{PanelFilterParam}}: a variant whose panel genotypes fall 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}.} +filter nothing. Individual-level genotypes are filtered by +\code{genotypeFilterParam} instead.} \item{signalScreenParam}{Individual-level pre-filter (ports the legacy \code{pip_cutoff_to_skip_ind}), built with @@ -136,13 +164,27 @@ 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{genotypeFilterParam}{Which individual-level variants and samples to +keep, built with \code{\link{GenotypeFilterParam}}: its +\code{keepSamples} narrows the dataset once, and its MAF, MAC, +variance, missingness, \code{keepVariants} and \code{keepIndel} +settings apply to each extracted block, as in +\code{\link{fineMappingPipeline}}. The default filters nothing. +\code{QtlDataset} and \code{MultiStudyQtlDataset} input only.} + +\item{phenotypeFilterParam}{The run's phenotype QC, built with +\code{\link{PhenotypeFilterParam}}. colocboost takes missing phenotype +values as they are, so unset keeps them; \code{"drop"} or +\code{"impute"} applies that instead, and \code{outlierAction = +"drop"} removes outlier samples. \code{QtlDataset} and +\code{MultiStudyQtlDataset} input only.} + \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 out of each side and --- through \code{scaleResiduals} --- whether the -columns are scaled to unit variance. Previously absent, which left this -pipeline on the dataset's own settings with no per-call say, unlike +columns are scaled to unit variance, as in \code{\link{fineMappingPipeline}} and \code{\link{twasWeightsPipeline}}. \strong{Ignored} on \code{QtlSumStats} input, which has nothing to residualize.} @@ -164,11 +206,15 @@ A \code{\linkS4class{ColocBoostResult}}: one element per \code{separate_gwas} runs. Outcome-specific (uncolocalized) sets are included with \code{isColocalized = FALSE}. - Project it with \code{\link{colocPairs}} (also available as - \code{as.data.frame}), \code{\link{colocVariants}} or - \code{\link{colocBoostOutcomes}}; timings are on + Project it with \code{\link{colocPairs}}, \code{\link{colocVariants}} + or \code{\link{colocBoostOutcomes}}; timings are on \code{\link{computingTime}} and the region-wide marginal - probabilities on \code{\link{regionVcp}}. + probabilities on \code{\link{regionVcp}}. \code{\link{ldReference}} + returns the LD references the summary statistics were matched against, + each stored once, and the \code{ldReference} column of + \code{colocBoostOutcomes()} names the one each outcome used. Its + \code{seqinfo()} names the genome build the inputs name; inputs naming + different builds are refused. } \description{ Protocol-level multi-trait colocalization analysis using @@ -178,10 +224,10 @@ Protocol-level multi-trait colocalization analysis using multi-context data. Per-context residualized X / Y are 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{ldReference}). Must already have + \item \code{QtlSumStats} -- summary-statistic-only QTL data with an + LD reference per row (\code{ldReference}). Must already have been passed through \code{\link{summaryStatsQc}} (the - pipeline rejects inputs whose \code{qcInfo()} is empty). + pipeline rejects inputs whose \code{qcOptions()} is empty). Every analysis variant is available on this input, including \code{xqtlColoc}, which colocalizes the QTL studies against each other with no GWAS involved. @@ -199,11 +245,10 @@ for either side; colocboost has its own variable-selection algorithm. \itemize{ \item Individual-level QC (MAF / MAC / X-variance / per-sample - missingness, sample / variant restrictions) lives on the - \code{QtlDataset} constructor and is applied lazily inside - \code{genotypes()} / \code{residualizedGenotypes()}. - The pipeline does \emph{not} run a separate - individual-level QC pass. + missingness, sample / variant restrictions) is + \code{genotypeFilterParam}, applied to each block of genotypes + the pipeline extracts. A \code{QtlDataset} records no filter + of its own. \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 @@ -218,7 +263,7 @@ for either side; colocboost has its own variable-selection algorithm. imputation, etc.) lives in \code{\link{summaryStatsQc}}. The pipeline rejects any \code{QtlSumStats} or \code{GwasSumStats} where - \code{length(qcInfo(x)) == 0L}. + \code{length(qcOptions(x)) == 0L}. } } @@ -230,15 +275,19 @@ for either side; colocboost has its own variable-selection algorithm. \code{gwasSumStats}. Works for either data form -- the individual-level contexts, the summary-level QTL studies, or both together when a \code{MultiStudyQtlDataset} carries a - mixture. This is the only variant that honors - \code{focalTrait}. - \item \code{jointGwas} (default \code{FALSE}): run a non-focal - colocboost model that combines all QTL contexts/studies - with the supplied \code{gwasSumStats} studies. - \item \code{separateGwas} (default \code{FALSE}): run one focal - colocboost model per GWAS study, where the GWAS is the - focal outcome. + mixture. Non-focal unless \code{focalOutcome} names one of its + QTL outcomes. + \item \code{jointGwas} (default \code{FALSE}): run one non-focal + colocboost model (colocboost's disease-agnostic mode) that + combines all QTL contexts/studies with the supplied + \code{gwasSumStats} studies, however many there are. + \item \code{separateGwas} (default \code{FALSE}): run one colocboost + model per GWAS study, focal on that study (the + disease-prioritized mode), even when there is only one. } + The flags combine freely, as in colocboost's own pipeline. With one + GWAS study, \code{jointGwas} and \code{separateGwas} fit the same + outcomes, one non-focal and one focal on the GWAS. } \examples{ diff --git a/man/combineFineMappingResults.Rd b/man/combineFineMappingResults.Rd index 5a0d5be7..50213bb5 100644 --- a/man/combineFineMappingResults.Rd +++ b/man/combineFineMappingResults.Rd @@ -10,9 +10,11 @@ combineFineMappingResults(..., ldReference = NULL) \item{...}{Two or more \code{FineMappingResultBase} objects, or a single \code{list} of them.} -\item{ldReference}{Optional genotype panel (see -\code{\link{readGenotypes}}) to attach to the -combined collection. Default \code{NULL}. Applied when combining two or +\item{ldReference}{Optional LD reference -- a genotype panel (see +\code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +\code{LdMatrix} -- that every row of the combined collection uses instead +of its own. Default \code{NULL}: each row keeps the reference it had, +and views of one source are stored once. Applied when combining two or more inputs; a single input is returned unchanged.} } \value{ diff --git a/man/combineGwasSumStats.Rd b/man/combineGwasSumStats.Rd index 40ce8ee1..5b5f56c4 100644 --- a/man/combineGwasSumStats.Rd +++ b/man/combineGwasSumStats.Rd @@ -10,9 +10,10 @@ combineGwasSumStats(..., ldReference = NULL) \item{...}{Two or more \code{GwasSumStats} objects, or a single \code{list} of them.} -\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) -to attach to the combined collection, overriding the unioned one. Default -\code{NULL}.} +\item{ldReference}{Optional LD reference -- a genotype panel (see +\code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +\code{LdMatrix} -- that every row of the combined collection uses +instead of its own. Default \code{NULL}.} } \value{ A single combined \code{GwasSumStats}. @@ -27,16 +28,16 @@ is carried through; a collection lacking an optional column is NA-padded. \details{ The three collection-level slots are merged rather than taken from the first 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 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}. +across the inputs (a mismatch is an error, not a silent first-wins), each +row keeps its own QC audit, so \code{\link{qcDiagnostics}} keeps +addressing the right element, and every row keeps its own LD reference. +References that are views of one source are stored once: genotype panels +read from the same files union into one panel over the shared genotype +handle (block-parallel pipelines narrow each +piece's panel to its own block, so a multi-block collection would otherwise +hold one panel per block), and an \code{LdMatrix} or +\code{GenotypeMixture} that another input's reference covers gives way to +that one. Inputs on unrelated references keep both. } \examples{ data(gwasSumStatsS4Example) diff --git a/man/combineQtlSumStats.Rd b/man/combineQtlSumStats.Rd index 4ac249b2..5322794e 100644 --- a/man/combineQtlSumStats.Rd +++ b/man/combineQtlSumStats.Rd @@ -10,9 +10,10 @@ combineQtlSumStats(..., ldReference = NULL) \item{...}{Two or more \code{QtlSumStats} objects, or a single \code{list} of them.} -\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) -to attach to the combined collection, overriding the unioned one. Default -\code{NULL}.} +\item{ldReference}{Optional LD reference -- a genotype panel (see +\code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +\code{LdMatrix} -- that every row of the combined collection uses +instead of its own. Default \code{NULL}.} } \value{ A single combined \code{QtlSumStats}. @@ -26,10 +27,9 @@ lacking an optional column is NA-padded. \details{ 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 -references combine the same way (all-\code{NULL} stays \code{NULL}, which -is the usual case for individual-level QTL data). +and the \code{\link{summaryStatsQc}} options must agree, each row keeps +its own QC audit, and the rows keep their own LD references, stored the +same way. } \examples{ data(qtlSumStatsExample) diff --git a/man/combineTwasWeights.Rd b/man/combineTwasWeights.Rd index 5b2f98b9..b6dd671b 100644 --- a/man/combineTwasWeights.Rd +++ b/man/combineTwasWeights.Rd @@ -10,9 +10,11 @@ combineTwasWeights(..., ldReference = NULL) \item{...}{Two or more \code{TwasWeights} objects, or a single \code{list} of them.} -\item{ldReference}{Optional genotype panel (see \code{\link{readGenotypes}}) -to attach to the -combined collection. Default \code{NULL}. Applied when combining two or +\item{ldReference}{Optional LD reference -- a genotype panel (see +\code{\link{readGenotypes}}), a \code{GenotypeMixture} or an +\code{LdMatrix} -- that every row of the combined collection uses instead +of its own. Default \code{NULL}: each row keeps the reference it had, +and views of one source are stored once. Applied when combining two or more inputs; a single input is returned unchanged.} } \value{ @@ -24,7 +26,7 @@ assembling per-gene weight sets into a single per-region collection for cTWAS. Joint-specification metadata columns are carried through. } \examples{ -twe <- twasWeightsRow( +twe <- TwasWeightsRow( variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) tw1 <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", diff --git a/man/computeCoefficientsGlasso.Rd b/man/computeCoefficientsGlasso.Rd index 9a7473af..27b9b11f 100644 --- a/man/computeCoefficientsGlasso.Rd +++ b/man/computeCoefficientsGlasso.Rd @@ -4,7 +4,7 @@ \alias{computeCoefficientsGlasso} \title{Compute initial mr.mash coefficients via group-lasso} \usage{ -computeCoefficientsGlasso(X, Y, standardize, numThreads, Xnew = NULL) +computeCoefficientsGlasso(X, Y, standardize, Xnew = NULL) } \arguments{ \item{X}{Numeric design matrix (samples x variants).} @@ -14,8 +14,6 @@ computeCoefficientsGlasso(X, Y, standardize, numThreads, Xnew = NULL) \item{standardize}{Logical; standardize the columns of \code{X} before fitting.} -\item{numThreads}{Integer; number of threads for the group-lasso fit.} - \item{Xnew}{Optional new design matrix for prediction; \code{NULL} returns in-sample coefficients.} } @@ -31,6 +29,5 @@ Fit a group-lasso (one group per response) to obtain initial estimates of the data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] Y <- matrix(rnorm(nrow(X) * 3), nrow(X), 3) -computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, - numThreads = 1L, Xnew = NULL) +computeCoefficientsGlasso(X = X, Y = Y, standardize = TRUE, Xnew = NULL) } diff --git a/man/computeCsCorrelation.Rd b/man/computeCsCorrelation.Rd index 79269927..6a1e8034 100644 --- a/man/computeCsCorrelation.Rd +++ b/man/computeCsCorrelation.Rd @@ -13,7 +13,7 @@ computeCsCorrelation(x, ldSource, ...) \S4method{computeCsCorrelation}{FineMappingResultBase,QtlDataset}(x, ldSource) } \arguments{ -\item{x}{A \code{\link{fineMappingRow}} carrying the fit (credible-set +\item{x}{A \code{\link{FineMappingRow}} carrying the fit (credible-set membership and PIP) and its variant ids.} \item{ldSource}{The object supplying the LD: a \code{QtlDataset} @@ -30,7 +30,7 @@ A numeric \code{m x m} between-credible-set correlation matrix } \description{ Compute the between-credible-set correlation matrix for a - \code{\link{fineMappingRow}} on demand from an LD source. The correlation + \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 reference --- and is deliberately never stored on the fit. An diff --git a/man/computeLd.Rd b/man/computeLd.Rd index cfcf9374..bef908c5 100644 --- a/man/computeLd.Rd +++ b/man/computeLd.Rd @@ -67,7 +67,7 @@ Correlation between variants, from either a dosage matrix } \examples{ data(qtlSumStatsExample) -panel <- ldReference(qtlSumStatsExample) +panel <- ldReference(qtlSumStatsExample)[[1L]] R <- computeLd(panel, snpIdx = 1:5) dim(R) # A dosage matrix already in memory is correlated directly. diff --git a/man/computingTime.Rd b/man/computingTime.Rd index 934c0460..fe632827 100644 --- a/man/computingTime.Rd +++ b/man/computingTime.Rd @@ -15,7 +15,11 @@ computingTime(x, ...) \item{...}{Ignored.} } \value{ -A list of timings, empty when none were recorded. +A \code{DataFrame}, one row per analysis that ran: + \code{analysis} (\code{xqtl_coloc}, \code{joint_gwas} or + \code{separate_gwas}), \code{nRuns} (1, or one per GWAS study for + \code{separate_gwas}) and \code{seconds}, their total wall-clock time. + No rows when none were recorded. } \description{ The wall-clock timings colocboostPipeline recorded for each diff --git a/man/credibleSetSummary.Rd b/man/credibleSetSummary.Rd index 5fc92104..f569bbbd 100644 --- a/man/credibleSetSummary.Rd +++ b/man/credibleSetSummary.Rd @@ -17,7 +17,7 @@ credibleSetSummary(x, ...) \item{coverage}{Credible-set coverage to summarise. Default 0.95.} } \value{ -A \code{tibble}: \code{cs, effect_id, coverage, n_variants, +A \code{DataFrame}: \code{cs, effect_id, coverage, n_variants, purity_min, purity_mean, V, cs_log10bf} (strongest member logBF), \code{cs_log_bf} (true per-effect single-effect log Bayes factor), \code{cs_pip} (summed member PIP = inclusion mass captured), diff --git a/man/credibleSets.Rd b/man/credibleSets.Rd index e07206b2..ae3acc99 100644 --- a/man/credibleSets.Rd +++ b/man/credibleSets.Rd @@ -13,7 +13,7 @@ credibleSets(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, + blockId = NULL, coverage = 0.95, minPurity = NULL ) @@ -35,9 +35,8 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} \item{coverage}{Numeric in (0, 1). Credible-set coverage level. Default \code{0.95}.} @@ -46,7 +45,11 @@ all regions.} retain; \code{NULL} applies no purity filter.} } \value{ -A data.frame of credible set information. +A \code{GRanges}, one range per credible-set member, carrying the + per-variant columns in \code{mcols()}; when the selectors match more + than one entry the row-identity columns are carried there too. Narrow it + with \code{subsetByOverlaps()}; take a table with + \code{as.data.frame()}. } \description{ Extract credible set assignments at the requested coverage. diff --git a/man/ctwasPipeline.Rd b/man/ctwasPipeline.Rd index bca7b03b..500c4dd6 100644 --- a/man/ctwasPipeline.Rd +++ b/man/ctwasPipeline.Rd @@ -9,9 +9,10 @@ ctwasPipeline( twasWeights, twasZ = NULL, fineMappingResult = NULL, + fineMappingMethod = NULL, method = NULL, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), ctwasPriorParam = CtwasPriorParam(), variantPruningParam = VariantPruningParam(), boundaryMergeParam = BoundaryMergeParam(), @@ -22,8 +23,8 @@ ctwasPipeline( \arguments{ \item{gwasSumStats}{A \code{\link{GwasSumStats}} whose elements are LD blocks (at least two), keyed by its \code{blockId} column, with -\code{qcInfo()} non-empty. Build it with -\code{loadGwasSumStatsFromManifest(..., ldBlocks = )} and pass it +\code{qcOptions()} non-empty. Build it with +\code{loadGwasSumStatsFromManifest(..., region = )} and pass it through \code{\link{summaryStatsQc}}.} \item{twasWeights}{The per-gene weight source. Either (a) a FLAT @@ -37,33 +38,47 @@ ctwas's joint group prior estimate (the legacy whole-chromosome pattern where only a few of many LD blocks carry gene weights). A gene whose cis span straddles a block boundary is homed by its single anchor; the cross-block signal is cTWAS's boundary-gene concern -(\code{\link{mergeCtwasBoundaryRegions}}), not placement.} +(\code{\link{mergeCtwasBoundaryRegions}}), not placement. A +\code{TwasWeights} row of the run's method that carries a SuSiE fit and +was narrowed since that fit warns (condition class +\code{pecotmrFitCoverage}): the fit no longer lines up with the row's +variants, so its weights are not renormalized over the variants kept.} \item{twasZ}{Optional \code{GRanges} of TWAS Z-scores (output of \code{\link{causalInferencePipeline}}). When supplied, the per-(trait, context) Z is used as the \code{z_gene} input to \code{ctwas_sumstats} so it is not recomputed.} -\item{fineMappingResult}{Optional \code{QtlFineMappingResult} or -\code{GwasFineMappingResult} carrying the per-variant PIP and credible-set -membership data used by the CS / PIP rescue filters (\code{csMinCor} and -\code{minPipCutoff}). When \code{NULL} (default) the smart filters are -no-ops; only the magnitude filter (\code{twasWeightCutoff}) and the -per-gene cap (\code{maxNumVariants}, ordered by \code{|weight|}) apply.} +\item{fineMappingResult}{Optional \code{QtlFineMappingResult}: the genes' +own fine-mapping, whose per-variant PIP and credible-set membership the +CS / PIP rescue filters (\code{csMinCor} and \code{minPipCutoff}) read. +Each gene is looked up by its weights' \code{(study, context, trait)} in +the fits of \code{fineMappingMethod}; a gene with no fit there gets no +rescue. When \code{NULL} (default) the smart filters are no-ops; only the +magnitude filter (\code{twasWeightCutoff}) and the per-gene cap +(\code{maxNumVariants}, ordered by \code{|weight|}) apply.} -\item{method}{Optional character (length 1). Picks which TWAS method's -weights to feed into ctwas for each (study, context, trait) gene. When -\code{NULL} (default): use \code{"ensemble"} if that method is present -across the weight sources; otherwise use the sole method when only one is -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{fineMappingMethod}{Character (length 1): the method of +\code{fineMappingResult} whose fits the rescues read, e.g. +\code{"susie"}. Required with a \code{fineMappingResult}, since the +weights' own method -- an \code{"ensemble"} or \code{"lasso"} weight -- +names no fine-mapping fit. Default \code{NULL}.} + +\item{method}{Character (length 1): which TWAS method's weights to feed +into ctwas for each (study, context, trait) gene, one method per run. +\code{NULL} (default) uses the pre-combined \code{"ensemble"} weights of +\code{TwasWeights}. Weights with no ensemble, and fine-mapping results as +the weight source, have no default: name the method (e.g. +\code{"mrash"}, or a fine-mapping method such as \code{"susie"}).} \item{maxNumSingleEffects}{Integer. Max number of single effects in cTWAS fine-mapping. Default \code{5}. Pass-through to \code{ctwas::ctwas_sumstats}.} -\item{numThreads}{Number of cores. Default \code{1}.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the cores +ctwas's own \code{ncore} parallelism uses when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +core. Default \code{SerialParam()}.} \item{ctwasPriorParam}{The EM stage that estimates cTWAS's group priors, built with \code{\link{CtwasPriorParam}}: \code{thin}, @@ -85,9 +100,9 @@ boundary has its regions merged and re-fine-mapped, built with \code{maxSnp}.} \item{keepSnps}{Logical (length 1). When \code{TRUE}, retain the -context-agnostic SNP background of each run as one extra \code{CtwasResult} -row (\code{study = context = "SNP"}, mirroring cTWAS's own \code{"SNP"} -group) so the full ctwas output is reconstructable from +context-agnostic SNP background of each run as extra \code{CtwasResult} +rows, one per region (\code{study = context = "SNP"}, mirroring cTWAS's +own \code{"SNP"} group) so the full ctwas output is reconstructable from \code{\link{ctwasPosteriors}} / \code{susieAlpha}. Default \code{FALSE} -- the SNP rows are the null background and are dropped from the structured gene-level result.} @@ -97,13 +112,16 @@ with \code{\link{CtwasOptions}}. Names are checked against what the ctwas steps accept between them.} } \value{ -A \code{\link{CtwasResult}} collection: one row per \code{(gwasStudy, - study, context, method)}. A single-context run is one row per method; a - multi-context (joint) run emits per-context rows sharing the same - \code{jointContexts} set and the jointly-estimated group priors. Each row's - \code{\link{CtwasResultEntry}} payload carries that context's per-gene - fine-mapping posteriors (\code{finemap}), the run's \code{param}, and its - \code{regionInfo}. For the raw \code{ctwas::finemap_regions} list (e.g. to +A \code{\link{CtwasResult}} collection: one row per + \code{(gwasStudy, study, context, method)} run and cTWAS region. A + single-context run gives each method its own rows; a multi-context + (joint) run emits per-context rows sharing the same \code{jointContexts} + set and the jointly-estimated group priors. Each row holds that region's + per-gene fine-mapping posteriors as ranges, with the region's per-effect + susie alpha table (\code{susieAlpha}), its \code{regionInfo} and the + run's \code{groupPriors} in \code{mcols()}. Its \code{seqinfo()} names + the genome build the inputs name; inputs naming different builds are + refused. For the raw \code{ctwas::finemap_regions} list (e.g. to feed \code{\link{mergeCtwasBoundaryRegions}}), call the granular \code{\link{assembleCtwasInputs}} \eqn{\to} \code{\link{estCtwasGroupPriors}} \eqn{\to} @@ -123,7 +141,7 @@ Pipeline that hands a per-block set of \code{gwasSumStats} is ONE \code{\link{GwasSumStats}} whose elements are LD blocks, keyed by its \code{blockId} column -- build it with - \code{loadGwasSumStatsFromManifest(..., ldBlocks = )}. Per-block + \code{loadGwasSumStatsFromManifest(..., region = )}. Per-block \code{region_info}, \code{LD_map}, and \code{snp_map} entries are built automatically from the LD reference and concatenated before the call to \code{ctwas::ctwas_sumstats}. A single-block input is rejected: cTWAS's EM @@ -141,9 +159,10 @@ Pipeline that hands a per-block set of } \section{LD reference compatibility check}{ - Per block: - \code{ldReference(twasWeights)} (when non-NULL) must be the same LD - reference as \code{ldReference(gwasSumStats)}. + Per block: the block's GWAS + rows must share one LD reference (a block's LD is one matrix), and every + weight row placed in the block that carries a reference must be the same + LD reference as theirs. Blocks may sit on different references. 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 @@ -165,12 +184,11 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldReference = ldStem, region = "chr22:10000000-19000000", - ldBlocks = blocks) + ldReference = ldStem, which = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) ctwasPipeline(gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample), + twasWeights = list(ctwasWeightsExample), method = "susie", ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), methodArgs = CtwasOptions( diff --git a/man/ctwasPosteriors.Rd b/man/ctwasPosteriors.Rd index f38d1d7b..bdf8962a 100644 --- a/man/ctwasPosteriors.Rd +++ b/man/ctwasPosteriors.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, -% R/CtwasResultEntry.R +% Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R, +% R/CtwasResult.R \name{ctwasPosteriors} \alias{ctwasPosteriors} -\alias{ctwasPosteriors,CtwasResult-method} \alias{ctwasPosteriors,CtwasResultEntry-method} +\alias{ctwasPosteriors,CtwasResult-method} \title{Get cTWAS Fine-mapping Posteriors} \usage{ ctwasPosteriors(x, ...) -\S4method{ctwasPosteriors}{CtwasResult}(x) - \S4method{ctwasPosteriors}{CtwasResultEntry}(x) + +\S4method{ctwasPosteriors}{CtwasResult}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} @@ -19,7 +19,12 @@ ctwasPosteriors(x, ...) \item{...}{Class-specific selection arguments.} } \value{ -A \code{data.frame} of posteriors (or \code{NULL} when absent). +On a \code{CtwasResultEntry}, the stored posteriors: a + \code{GRanges} when the pipeline placed its rows (each table column in + \code{mcols()}), the table as given otherwise, or \code{NULL} when + absent. On a \code{CtwasResult}, one \code{GRanges} of every row's + posteriors with the run identity in \code{mcols()} (empty when no row + has any); a row whose payload carries no coordinates is an error. } \description{ Return the per-gene (and per-SNP) fine-mapping posterior table diff --git a/man/dentist.Rd b/man/dentist.Rd index 75cbb254..9a71d5c2 100644 --- a/man/dentist.Rd +++ b/man/dentist.Rd @@ -53,7 +53,7 @@ through \code{computeLd}. Ignored when \code{R} is provided directly.} \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} +\code{duprThreshold}, \code{BPPARAM}, \code{correctChenEtAlBug} and \code{seed}. This is the same record \code{\link{ldMismatchQc}} takes as \code{method = DentistParam(...)}, so a setting means the same thing diff --git a/man/dentistSingleWindow.Rd b/man/dentistSingleWindow.Rd index 025f2400..b7760a8a 100644 --- a/man/dentistSingleWindow.Rd +++ b/man/dentistSingleWindow.Rd @@ -15,7 +15,7 @@ dentistSingleWindow( nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - numThreads = 1, + BPPARAM = SerialParam(), correctChenEtAlBug = TRUE, ldMethod = "sample", seed = NULL @@ -48,7 +48,10 @@ provided; inferred from \code{X} when \code{X} is provided.} \item{duprThreshold}{Duplicate r-squared threshold. Default is 0.99.} -\item{numThreads}{Number of CPU cores. Default is 1.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the +threads DENTIST's OpenMP loops use when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +thread. Default \code{SerialParam()}.} \item{correctChenEtAlBug}{Correct the original DENTIST operator! bug. Default is TRUE.} diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index 44d16753..b9ba0ba1 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -7,32 +7,35 @@ .penalizedRssWeights( stat, ldReference, - penalty, + spec, s = c(0.2, 0.5, 0.9, 1), - gamma = NULL, - alpha = 1, - lambda0 = 0, - lambda2 = 0, selection = c("ldQuadratic", "minFbeta"), fitRetention = c("none", "slim", "full"), - methodArgs = PenalizedRssOptions() + methodArgs = PenalizedRssOptions(), + label = str_c(str_to_lower(spec$penalty), "RssWeights") ) } \arguments{ -\item{stat, ldReference, s, selection, penalty, gamma, alpha, lambda0, lambda2}{See -the public wrappers for details.} +\item{stat, ldReference, s, selection}{See the public wrappers for details.} + +\item{spec}{The penalty, built by the calling wrapper from its own +arguments (internal \code{.rssPenalty()}).} \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}}.} +\code{\link{PenalizedRssOptions}}: the path only, since the penalty is +the wrapper's.} + +\item{label}{The calling wrapper's name, for its error messages.} } \value{ Numeric weight vector, one weight per variant of \code{stat}. } \description{ -Shared implementation for \code{scadRssWeights()} and \code{mcpRssWeights()}. +Shared implementation for \code{scadRssWeights()}, \code{mcpRssWeights()}, +\code{enetRssWeights()} and \code{ridgeRssWeights()}. (\code{l0learnRssWeights()} uses the lower-level \code{.rssShrinkGridWeights} scaffold directly, since it sweeps an additional \code{lambda0} path.) Searches over a shrinkage grid \code{s} (LD matrix shrinkage \code{(1-s)R + diff --git a/man/dot-regionToSnpIdx.Rd b/man/dot-regionToSnpIdx.Rd index a7f3c44e..ad579ef5 100644 --- a/man/dot-regionToSnpIdx.Rd +++ b/man/dot-regionToSnpIdx.Rd @@ -9,13 +9,13 @@ \arguments{ \item{snpInfo}{data.frame with CHR and BP columns.} -\item{region}{Character region string "chr:start-end".} +\item{region}{A \code{GRanges} window, of one range or several.} } \value{ Integer vector of matching SNP indices. } \description{ Return 1-based indices into snpInfo for SNPs within a genomic - region string. + window. } \keyword{internal} diff --git a/man/enetRssWeights.Rd b/man/enetRssWeights.Rd new file mode 100644 index 00000000..f48f5ed9 --- /dev/null +++ b/man/enetRssWeights.Rd @@ -0,0 +1,94 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{enetRssWeights} +\alias{enetRssWeights} +\title{Compute Elastic-Net Weights from Summary Statistics} +\usage{ +enetRssWeights( + stat, + ldReference, + alpha = 0.5, + s = c(0.2, 0.5, 0.9, 1), + selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), + methodArgs = PenalizedRssOptions() +) +} +\arguments{ +\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{alpha}{Elastic-net mixing in \code{[0, 1]}: the L1 share of the +penalty. Default 0.5.} + +\item{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, +0.5, 0.9, 1.0)}.} + +\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or +\code{"minFbeta"}.} + +\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. Unless + \code{fitRetention = "none"}, the search is attached as attribute + \code{"fit"}. +} +\description{ +Fits the elastic net on the RSS objective -- the lasso penalty mixed with +a ridge term, as glmnet mixes them -- searching over a shrinkage grid +\code{s} and a lambda path. Model selection uses LD-quadratic +pseudovalidation by default. +} +\details{ +\code{alpha} is the L1 share of the penalty: with \eqn{l_1 = \lambda +\alpha} and \eqn{l_2 = \lambda (1 - \alpha)} the penalty is +\eqn{2 l_1 \|\beta\|_1 + l_2 \beta^T \beta}, so \code{alpha = 1} is the +lasso and \code{alpha = 0} ridge (\code{\link{ridgeRssWeights}}). The +default lambda path is divided by \code{max(alpha, 0.001)}, as glmnet +sizes its own, so the L1 share spans the same range at any \code{alpha}. + +The LD shrinkage adds a ridge term of its own, since +\eqn{\beta^T R_s \beta = (1 - s) \beta^T R \beta + s \beta^T \beta}: every +RSS lasso is already partly a ridge, and \code{alpha} adds a second ridge +term that grows with \eqn{\lambda}. Expect the lasso and the elastic net +to differ less on summary statistics than glmnet's do on genotypes. +} +\examples{ +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:30] +y <- eqtlRegionExample$yRes +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)), + variantNames = colnames(X) +) +enetRssWeights(stat, LdMatrix(cor(X))) +# A larger ridge share: +enetRssWeights(stat, LdMatrix(cor(X)), alpha = 0.2) +} diff --git a/man/enetWeights.Rd b/man/enetWeights.Rd index d983cd16..97832af9 100644 --- a/man/enetWeights.Rd +++ b/man/enetWeights.Rd @@ -2,15 +2,18 @@ % Please edit documentation in R/regularizedRegressionWrappers.R \name{enetWeights} \alias{enetWeights} -\title{Compute TWAS weights via elastic net (glmnet, alpha = 0.5)} +\title{Compute TWAS weights via elastic net (glmnet)} \usage{ -enetWeights(X, y, methodArgs = GlmnetOptions()) +enetWeights(X, y, alpha = 0.5, methodArgs = GlmnetOptions()) } \arguments{ \item{X}{Numeric genotype / design matrix (samples x variants).} \item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} +\item{alpha}{Elastic-net mixing in \code{[0, 1]}: the L1 share of the +penalty. Default 0.5.} + \item{methodArgs}{Additional arguments forwarded to \code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare list is refused, since it cannot be checked against the engine's formals.} @@ -19,11 +22,14 @@ list is refused, since it cannot be checked against the engine's formals.} Numeric vector of length \code{ncol(X)} of per-variant weights. } \description{ -Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0.5}. +Convenience wrapper for \code{\link{glmnetWeights}} at a mixing between the +lasso and ridge, \code{alpha = 0.5} unless set. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:30] y <- eqtlRegionExample$yRes enetWeights(X, y) +# A larger ridge share: +enetWeights(X, y, alpha = 0.2) } diff --git a/man/estCtwasGroupPriors.Rd b/man/estCtwasGroupPriors.Rd index 23b8793c..2118f587 100644 --- a/man/estCtwasGroupPriors.Rd +++ b/man/estCtwasGroupPriors.Rd @@ -7,7 +7,7 @@ estCtwasGroupPriors( inputs, ctwasPriorParam = CtwasPriorParam(), - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) } @@ -22,7 +22,10 @@ accurate EM iterations), \code{varStructure}, and on a degenerate input is recovered by re-running only the prefit step and returning those (typically finite) priors.} -\item{numThreads}{Number of cores.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the cores +ctwas's own \code{ncore} parallelism uses when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +core. Default \code{SerialParam()}.} \item{methodArgs}{Additional arguments forwarded to ctwas, built with \code{\link{CtwasOptions}}. Names are checked against what diff --git a/man/exportToVcf.Rd b/man/exportToVcf.Rd deleted file mode 100644 index 112b90bc..00000000 --- a/man/exportToVcf.Rd +++ /dev/null @@ -1,115 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/resultWriters.R -\name{exportToVcf} -\alias{exportToVcf} -\alias{exportToVcf,list-method} -\alias{exportToVcf,GwasSumStats-method} -\alias{exportToVcf,FineMappingResultBase-method} -\alias{exportToVcf,TwasWeights-method} -\title{Export a result to VCF/BCF} -\usage{ -exportToVcf(x, outputPath, sampleName = NULL, ...) - -\S4method{exportToVcf}{list}(x, outputPath, sampleName = NULL, ...) - -\S4method{exportToVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, studyName = NULL) - -\S4method{exportToVcf}{FineMappingResultBase}( - x, - outputPath, - sampleName = NULL, - studyName = NULL, - context = NULL, - trait = NULL, - method = NULL, - splitByContext = FALSE, - splitByTrait = FALSE -) - -\S4method{exportToVcf}{TwasWeights}( - x, - outputPath, - sampleName = NULL, - studyName = NULL, - context = NULL, - trait = NULL, - method = NULL -) -} -\arguments{ -\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, -\code{.vcf} for uncompressed VCF.} - -\item{sampleName}{Name(s) for the VCF sample column(s). Default \code{NULL} -derives them from the object's identity tuple.} - -\item{...}{Additional arguments passed to methods.} - -\item{studyName}{Character or \code{NULL}. Restrict the written records to -this study; \code{NULL} includes all studies.} - -\item{context}{Character or \code{NULL}. Restrict the written records to this -context; \code{NULL} includes all contexts.} - -\item{trait}{Character or \code{NULL}. Restrict the written records to this -trait; \code{NULL} includes all traits.} - -\item{method}{Character or \code{NULL}. Restrict the written records to this -method; \code{NULL} includes all methods.} - -\item{splitByContext}{Logical. If \code{TRUE}, write one VCF per context. -Default \code{FALSE}.} - -\item{splitByTrait}{Logical. If \code{TRUE}, write one VCF per trait. Default -\code{FALSE}.} -} -\value{ -Invisible path(s) to the written file(s). -} -\description{ -Writes GWAS summary statistics, fine-mapping results or TWAS weights to a -GWAS-VCF-style file via VariantAnnotation and Rsamtools: one record per -variant, one SAMPLE per study / fitted model, and the per-variant statistics -as FORMAT fields. Supports bgzipped VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) -additionally needs a working \code{Rsamtools::asBcf()}, which recent -Rsamtools releases disable, so prefer .vcf.bgz. -} -\details{ -Which FORMAT fields are written depends on the input: -\describe{ - \item{\code{GwasSumStats}}{\code{ES} / \code{SS} / \code{AF} for one - study.} - \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).} - \item{\code{TwasWeights}}{\code{WGT}, the prediction weight.} -} - -Every fit the selectors match becomes a SAMPLE of ONE file: the records are -the union of their variants, the FORMAT schema is the union of their fields, -and a fit that did not include a variant -- or does not report a field -- -leaves those cells empty. So two methods over a region, or a dozen weight -methods for one gene, are compared by reading one file rather than a dozen. -Each sample is described in its own \code{##SAMPLE} header line, carrying -the fit's identity tuple and how many variants it contributed. -Cross-validation results are not exported -- see \code{\link{exportToBed}} -for why -- and an export requires the full-data fit. - -\code{splitByContext} / \code{splitByTrait} opt out of that and write one -single-sample file per fit, at a path decorated with the axis value. -} -\examples{ -data(gwasSumStatsS4Example) -exportToVcf( - gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) -} -\seealso{ -\code{\link{exportToBed}} -} diff --git a/man/extractCsInfo.Rd b/man/extractCsInfo.Rd index b60d67e6..0fb452fa 100644 --- a/man/extractCsInfo.Rd +++ b/man/extractCsInfo.Rd @@ -7,7 +7,7 @@ extractCsInfo(fmRow, csNames, topLociTable, ldSource) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +\item{fmRow}{A \code{\link{FineMappingRow}}, or a single-row fine-mapping collection as returned by \code{\link{fineMappingResult}}, carrying the SuSiE fit and variant ids.} @@ -59,7 +59,7 @@ vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") fit <- list(pip = c(0.1, 0.7, 0.2), sets = list(cs = list(L_1 = c(1, 2)))) tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2), z = c(1.0, 3.5, -0.5)) -fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +fe <- FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) # A single credible set has no between-CS correlation (cs_corr_* are NA), so # the ldSource is not consulted here. extractCsInfo(fe, csNames = "L_1", topLociTable = tl, diff --git a/man/extractTopPipInfo.Rd b/man/extractTopPipInfo.Rd index 09652da6..a3e09936 100644 --- a/man/extractTopPipInfo.Rd +++ b/man/extractTopPipInfo.Rd @@ -7,7 +7,7 @@ extractTopPipInfo(fmRow, sumstats) } \arguments{ -\item{fmRow}{A \code{\link{fineMappingRow}}, or a single-row +\item{fmRow}{A \code{\link{FineMappingRow}}, or a single-row fine-mapping collection as returned by \code{\link{fineMappingResult}}, carrying the SuSiE fit and variant ids.} @@ -49,7 +49,7 @@ This function is particularly useful for capturing information about vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") fit <- list(pip = c(0.1, 0.7, 0.2)) tl <- data.frame(variant_id = vids, pip = c(0.1, 0.7, 0.2)) -fe <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +fe <- FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) extractTopPipInfo(fe, sumstats = list(z = c(1.0, 3.5, -0.5))) } diff --git a/man/fillFromReference.Rd b/man/fillFromReference.Rd new file mode 100644 index 00000000..da5b41ee --- /dev/null +++ b/man/fillFromReference.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\name{fillFromReference} +\alias{fillFromReference} +\title{Fill A Per-Variant Column From A Reference} +\usage{ +fillFromReference( + x, + reference, + column = c("AF", "MAF", "N"), + studyName = NULL, + context = NULL, + trait = NULL +) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{reference}{A \code{GRanges} carrying \code{A1} and \code{A2} in +\code{mcols()} plus the values: a column named like \code{column}, or +else its one column besides \code{A1}/\code{A2}.} + +\item{column}{Which column to fill: \code{"AF"} (default), \code{"MAF"} or +\code{"N"}.} + +\item{studyName, context, trait}{Selectors pinning one study (every row of a +GWAS study) or one \code{QtlSumStats} entry; \code{context} and +\code{trait} are \code{QtlSumStats}-only.} +} +\value{ +\code{x}, with the selection's column filled. +} +\description{ +Fill the \code{AF}, \code{MAF} or \code{N} column of a + \code{GwasSumStats} / \code{QtlSumStats} selection from a reference + \code{GRanges}, pairing variants on \code{(chrom, pos, A1, A2)} -- the + usual case being effect-allele frequencies the source file did not + carry, taken from a reference panel. Order does not matter. + + An allele swap sends \code{AF} to \code{1 - AF}, so a flipped match is + complemented; \code{MAF} is \code{min(af, 1 - af)} and \code{N} is a + count, both swap-invariant, so neither is. A selected variant the + reference does not name is set \code{NA} -- its value is unknown, not + unchanged -- with a warning, and so is a reference variant the selection + does not hold; no overlap at all is an error. + + Values already in \code{\link{sumStats}} order are assigned positionally + instead, with \code{af(x) <- value} (see + \code{\link{variantColumnReplace}}). +} +\examples{ +data(qtlSumStatsExample) +ref <- sumStats(qtlSumStatsExample) +S4Vectors::mcols(ref) <- S4Vectors::DataFrame( + A1 = ref$A1, + A2 = ref$A2, + AF = runif(length(ref)) +) +x <- fillFromReference(qtlSumStatsExample, ref, "AF") +head(af(x)) +} diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index 672fceee..3fe90d18 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -31,7 +31,7 @@ fineMappingPipeline(data, ...) seed = NULL, mrmashPrior = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, fitRetention = c("slim", "full"), dataType = NULL @@ -60,7 +60,7 @@ fineMappingPipeline(data, ...) usePCA = FALSE, nPCs = 10L, seed = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, fitRetention = c("slim", "full"), dataType = NULL @@ -71,6 +71,7 @@ fineMappingPipeline(data, ...) methods, contexts = NULL, traitId = NULL, + cisWindow = NULL, jointSpecification = NULL, initializeWithSusieInf = TRUE, credibleSetParam = CredibleSetParam(), @@ -103,7 +104,10 @@ fineMappingPipeline(data, ...) } \arguments{ \item{data}{A \code{QtlDataset}, \code{MultiStudyQtlDataset}, -\code{QtlSumStats}, or \code{GwasSumStats}.} +\code{QtlSumStats}, or \code{GwasSumStats}. Each row of a +\code{GwasSumStats} is fine-mapped as one region, so it should be an LD +block (load one block, or split the study with a \code{region}); a row +spanning more than 20 Mb, as a whole chromosome does, draws a warning.} \item{...}{Reserved for future per-method arguments.} @@ -126,9 +130,9 @@ fineMappingPipeline(data, ...) even when fitting from a susieInf chain). }} -\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 +\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.} @@ -141,23 +145,30 @@ 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.} +trait) pairs a per-context entry leaves out. In a MultiStudyQtlDataset +a study left with no trait selected sits out; the run is refused only +when no study or summary-statistics row has one.} \item{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 -\code{traitId}.} +\code{GRanges}. Mutually exclusive with \code{traitId}.} \item{cisWindow}{For QtlDataset: cis-window (bp) around each trait's genomic position when extracting variants. Required when \code{traitId} is -supplied. Mutually exclusive with \code{region}.} - -\item{genotypeFilterParam}{Per-call overrides of the \code{QtlDataset}'s own -filters, built with \code{\link{GenotypeFilterParam}}. A field left unset -keeps the dataset's construct-time value, so -\code{GenotypeFilterParam(mafCutoff = 0)} pins the cutoff at zero while -\code{GenotypeFilterParam()} changes nothing. Applies to the -\code{QtlDataset} method only.} +supplied. Mutually exclusive with \code{region}. For QtlSumStats: +optional; each selected tuple is analysed over its \code{traitPos} +\eqn{\pm} \code{cisWindow}, within its \code{region}, which is then +the window its result records. Every selected tuple needs a +\code{traitPos}. A MultiStudyQtlDataset applies it to each of its +studies, individual-level or summary-statistics, as above.} + +\item{genotypeFilterParam}{Which variants and samples the run keeps, built +with \code{\link{GenotypeFilterParam}}: its \code{keepSamples} narrows +the dataset once, and its MAF, MAC, variance, missingness, +\code{keepVariants} and \code{keepIndel} settings apply to each +extracted block, against that block's samples. A field left unset +filters nothing. A \code{QtlDataset} records no filter of its own, so +this is the only one. \code{QtlDataset} and +\code{MultiStudyQtlDataset} input only.} \item{jointRegions}{For QtlDataset with a multi-range \code{region}: \code{FALSE} (default) fits each range independently and merges the @@ -213,7 +224,7 @@ present are not refit.} \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} + CV), \code{BPPARAM} 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 @@ -301,8 +312,12 @@ priors. \code{NULL} uses the canonical prior instead.} which data-driven prior weights are zeroed; \code{NULL} disables the cutoff.} -\item{naAction}{Character. How to handle missing values in the extracted -phenotype/genotype data.} +\item{phenotypeFilterParam}{The run's phenotype QC, built with +\code{\link{PhenotypeFilterParam}}: how missing phenotype values are +handled (unset drops the affected samples; \code{"impute"} fills each +trait's mean; a fit cannot take \code{"keep"}) and whether outlier +samples are dropped. Every fit of the run, joint ones included, reads +its phenotypes under it.} \item{verbose}{Verbosity (0 silent, 1 default). Default \code{1}.} @@ -317,9 +332,10 @@ either way --- its per-credible-set columns are governed by \item{dataType}{Optional assay / modality label for the phenotype the fit was run on (\code{"bulk_rnaseq"}, \code{"methylation"}), recorded as a -per-row provenance column and published by \code{\link{exportToBed}} / -\code{\link{exportToVcf}}. \code{NULL} (default) omits the column. It -cannot be derived --- the input carries the values, not what they measure.} +per-row provenance column and published by \code{\link{writeBed}} / +\code{\link{writeGwasVcf}}. \code{NULL} (default) omits +the column. It cannot be derived --- the input carries the values, not +what they measure.} \item{panelFilterParam}{LD-reference-panel filters for the summary-statistics and GWAS methods, built with \code{\link{PanelFilterParam}}. See @@ -359,10 +375,11 @@ and GWAS methods, built with \code{\link{PanelFilterParam}}. See 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{ldReference} for RSS-derived - fits. + Each row records the LD reference its fit used: none for + individual-level (QtlDataset / all-individual-level + MultiStudyQtlDataset) fits, the reference of the input row it was fitted + from for RSS-derived fits. Its \code{seqinfo()} names the genome build + the inputs name; inputs naming different builds are refused. } \description{ S4-dispatched per-region fine-mapping entry point that @@ -431,7 +448,7 @@ S4-dispatched per-region fine-mapping entry point that \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} + on inputs where \code{length(qcOptions(x)) == 0L}. \code{summaryStatsQc} 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 @@ -475,12 +492,14 @@ deliberately not ported here: 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}. + provenance is recorded on the sumstats: \code{qcOptions()} and, + per row, \code{qcInfo()}. \item An entry that \code{summaryStatsQc(pipCutoffToSkip = ...)} screened - out (recorded as \code{qcInfo$entryAudit[[i]]$pipScreenSkipped}, and - emptied to 0 variants) is \strong{skipped}, not fit: it produces no - row and a message with the screen reason. An all-screened collection - yields a valid empty result rather than an error. + out (recorded in its row's \code{pipScreenSkipped} column of + \code{qcInfo()}, and emptied to 0 variants) is \strong{skipped}, + not fit: it produces no row and a message with the screen reason. + An all-screened collection yields a valid empty result rather than + an error. } } @@ -507,12 +526,11 @@ deliberately not ported here: Individual-level genotypes reach every fit centred and scaled to unit variance, so a posterior effect --- which is the prediction weight --- is on the standardized scale, and the published - \code{weight_standardized} records it. That scaling belongs to the - \code{QtlDataset} accessors, not to this pipeline: it is - \code{\link{residualizedGenotypes}} that applies it, governed by - \code{ResidualizationParam(scaleResiduals = )} per call with the - dataset's own \code{\link{scaleResiduals}} slot as the default. One - mechanism, one place, shared with \code{\link{twasWeightsPipeline}} and + \code{weight_standardized} records it. The residualization that applies + it (\code{\link{residualizedGenotypes}}) is governed by + \code{ResidualizationParam(scaleResiduals = )}, which defaults to + \code{TRUE}. One mechanism, one place, shared with + \code{\link{twasWeightsPipeline}} and \code{\link{colocboostPipeline}}. An RSS fit needs nothing done: its likelihood is written in standardized units already. diff --git a/man/fineMappingResult.Rd b/man/fineMappingResult.Rd index dfd8b1b0..3a71a3d3 100644 --- a/man/fineMappingResult.Rd +++ b/man/fineMappingResult.Rd @@ -5,14 +5,15 @@ \alias{fineMappingResult} \alias{fineMappingResult,GwasFineMappingResult-method} \alias{fineMappingResult,QtlFineMappingResult-method} -\title{Get a Single Fine-Mapping Entry} +\title{Get One Fine-Mapping Fit} \usage{ fineMappingResult( x, studyName = NULL, context = NULL, trait = NULL, - method = NULL + method = NULL, + blockId = NULL ) \S4method{fineMappingResult}{GwasFineMappingResult}( @@ -20,7 +21,8 @@ fineMappingResult( studyName = NULL, context = NULL, trait = NULL, - method = NULL + method = NULL, + blockId = NULL ) \S4method{fineMappingResult}{QtlFineMappingResult}( @@ -28,23 +30,31 @@ fineMappingResult( studyName = NULL, context = NULL, trait = NULL, - method = NULL + method = NULL, + blockId = NULL ) } \arguments{ \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.} +\item{studyName, context, trait, method}{Single character identifiers. +Required when the collection holds more than one fit; optional when it +holds one. \code{context} and \code{trait} are QTL-only.} + +\item{blockId}{GWAS only: the \code{blockId} of one LD block, to select +that block alone. \code{NULL} (default) selects every block of the fit.} } \value{ -A single-row collection of the same class as \code{x}. +A collection of the same class as \code{x}: one row for a QTL fit, + one row per selected block for a GWAS fit. } \description{ -Return one row of a \code{QtlFineMappingResult} or - \code{GwasFineMappingResult}, selected by its identity, as a single-row - collection of the same class. +Return the rows of one fit of a \code{QtlFineMappingResult} + or \code{GwasFineMappingResult}, selected by its identity, as a + collection of the same class. A QTL fit is one row. A GWAS study + fine-mapped block by block holds one row per LD block, so its fit is + every block of the \code{(study, method)} pair, unless \code{blockId} + names one or \code{region} narrows them. } \examples{ data(qtlFineMappingExample) diff --git a/man/finemapCtwasRegions.Rd b/man/finemapCtwasRegions.Rd index d5009fdb..69557350 100644 --- a/man/finemapCtwasRegions.Rd +++ b/man/finemapCtwasRegions.Rd @@ -7,7 +7,7 @@ finemapCtwasRegions( screenResult, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) } @@ -16,7 +16,10 @@ finemapCtwasRegions( \item{maxNumSingleEffects}{Pass-through.} -\item{numThreads}{Number of cores.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the cores +ctwas's own \code{ncore} parallelism uses when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +core. Default \code{SerialParam()}.} \item{methodArgs}{Additional arguments forwarded to ctwas, built with \code{\link{CtwasOptions}}. Names are checked against what @@ -47,12 +50,11 @@ blocks <- GenomicRanges::GRanges("chr22", IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), blockId = c("chr22_1", "chr22_2")) gss <- loadGwasSumStatsFromManifest(manifest = mani, genome = "hg38", - ldReference = ldStem, region = "chr22:10000000-19000000", - ldBlocks = blocks) + ldReference = ldStem, which = blocks) gwasByRegion <- summaryStatsQc(gss, panelFilterParam = PanelFilterParam(mafCutoff = 0.0025)) inp <- assembleCtwasInputs(gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample)) + twasWeights = list(ctwasWeightsExample), method = "susie") est <- estCtwasGroupPriors(inp, ctwasPriorParam = CtwasPriorParam(thin = 1, niterPrefit = 3, niter = 10, fallbackToPrefit = TRUE), diff --git a/man/flattenTupleRanges.Rd b/man/flattenTupleRanges.Rd index c933b7ba..23895c59 100644 --- a/man/flattenTupleRanges.Rd +++ b/man/flattenTupleRanges.Rd @@ -2,6 +2,7 @@ % Please edit documentation in R/RangedTupleList.R \name{flattenTupleRanges} \alias{flattenTupleRanges} +\alias{coerce,RangedTupleList,GRanges-method} \title{Flatten a tuple collection to a plain GRanges} \usage{ flattenTupleRanges(x) @@ -34,9 +35,12 @@ Non-atomic \code{mcols} columns -- the per-element \code{susieFit} / \code{cvResult} payloads -- are dropped. They describe an element, not a range, so there is no row to broadcast them onto. Use the accessors (\code{\link{susieFit}}, \code{\link{cvResult}}) for those. + +\code{as(x, "GRanges")} is the same conversion. } \examples{ data(qtlFineMappingExample) flat <- flattenTupleRanges(qtlFineMappingExample) head(names(S4Vectors::mcols(flat))) +identical(as(qtlFineMappingExample, "GRanges"), flat) } diff --git a/man/frqData.Rd b/man/frqData.Rd index b13f6806..6c68b285 100644 --- a/man/frqData.Rd +++ b/man/frqData.Rd @@ -13,7 +13,7 @@ frqData(x) \item{x}{An \code{\link{SldscData}} object.} } \value{ -A \code{data.frame} of reference-panel frequencies (SNP, MAF). +A \code{DataFrame} of reference-panel frequencies (SNP, MAF). } \description{ Get the allele-frequency table from an SldscData diff --git a/man/fsusieCredibleBand.Rd b/man/fsusieCredibleBand.Rd index dc80ec4a..6d7e1e28 100644 --- a/man/fsusieCredibleBand.Rd +++ b/man/fsusieCredibleBand.Rd @@ -15,19 +15,21 @@ fsusieCredibleBand(x, ...) \item{...}{Ignored.} } \value{ -A long \code{tibble}: \code{cs, chrom, pos, effect, lower, upper, - halfwidth} -- \code{halfwidth} being \code{(upper - lower) / 2}, the - symmetric band half-width publication tables carry (the collection method - additionally carries the entry identity columns). +A \code{GRanges}, one width-1 range per (credible set, grid + position), whose \code{mcols()} hold \code{cs, chrom, pos, effect, + lower, upper, halfwidth} -- \code{halfwidth} being + \code{(upper - lower) / 2}, the symmetric band half-width publication + tables carry (the collection method additionally carries the entry + identity columns). } \description{ For a functional-SuSiE (\code{fsusieR::susiF}) fine-mapping entry, returns the fitted effect curve and its credible band over the functional grid, one -row per (credible set, grid position). Wraps the upstream fSuSiE band +range per (credible set, grid position). Wraps the upstream fSuSiE band computation (fsusieR's internal \code{update_cal_credible_band.susiF} + \code{get_fitted_effect}). Uses saved bands in trimmed fits, or computes -them from an untrimmed fit. Returns zero rows when the functional fields -are absent. +them from an untrimmed fit. Returns an empty \code{GRanges} when the +functional fields are absent. } \examples{ data(fsusieFineMappingExample) diff --git a/man/fsusieTraitEffects.Rd b/man/fsusieTraitEffects.Rd index b3863652..5f7241c2 100644 --- a/man/fsusieTraitEffects.Rd +++ b/man/fsusieTraitEffects.Rd @@ -15,7 +15,7 @@ fsusieTraitEffects(x, ...) \item{...}{Ignored.} } \value{ -A long \code{tibble}: \code{cs, chrom, jointTrait, traitPos, +A long \code{DataFrame}: \code{cs, chrom, jointTrait, traitPos, effect} (the collection method additionally carries the entry identity columns). } diff --git a/man/genomicRegion.Rd b/man/genomicRegion.Rd index 80f8341f..85bd933a 100644 --- a/man/genomicRegion.Rd +++ b/man/genomicRegion.Rd @@ -1,16 +1,13 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/twasWeights.R +% Please edit documentation in R/AllGenerics.R, R/RangedTupleList.R \name{genomicRegion} \alias{genomicRegion} -\alias{genomicRegion,FineMappingResultBase-method} -\alias{genomicRegion,TwasWeights-method} +\alias{genomicRegion,RangedTupleList-method} \title{Get Per-Row Analysis Windows} \usage{ genomicRegion(x, ...) -\S4method{genomicRegion}{FineMappingResultBase}(x) - -\S4method{genomicRegion}{TwasWeights}(x) +\S4method{genomicRegion}{RangedTupleList}(x) } \arguments{ \item{x}{The object.} @@ -24,10 +21,13 @@ 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 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). + \code{TwasWeights}; 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}); for summary statistics the + LD block or window the row was loaded for (the \code{region} given to the + constructor or loader), else the span of its variants before QC. This is + location provenance (e.g. for cTWAS LD-block placement). One method + serves every collection. This is the window that was ANALYSED, not the span of the variants that survived into the fit: QC and screening drop variants first, so a fit over @@ -36,7 +36,7 @@ Return the genomic interval each row was analysed over, as a recovered from the object; the span can, and is simply \code{range(x)}. Being a record of what was analysed, it deliberately does NOT change under - \code{subsetRegion()} or row subsetting -- a subset of a fit's variants was + subsetting -- a subset of a fit's variants was still produced by a fit over the original window. Use \code{range(x)} when you want the current content instead. @@ -46,6 +46,8 @@ Return the genomic interval each row was analysed over, as a \examples{ data(qtlFineMappingExample) genomicRegion(qtlFineMappingExample) +data(gwasSumStatsS4Example) +genomicRegion(gwasSumStatsS4Example) } \seealso{ \code{\link{traitPosition}} for the trait's own coordinates. diff --git a/man/genotypes.Rd b/man/genotypes.Rd index 42377daf..eda3e79e 100644 --- a/man/genotypes.Rd +++ b/man/genotypes.Rd @@ -7,35 +7,21 @@ \usage{ genotypes(x, ...) -\S4method{genotypes}{QtlDataset}(x, traitId = NULL, region = NULL, cisWindow = NULL, samples = NULL) +\S4method{genotypes}{QtlDataset}(x) } \arguments{ \item{x}{The object to extract from.} -\item{...}{Class-specific selection arguments (e.g., \code{traitId}, -\code{region}, \code{cisWindow} for \code{QtlDataset}).} - -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier -to select; \code{NULL} matches all traits in the dataset.} - -\item{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.} - -\item{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window -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{...}{Passed on to methods.} } \value{ A numeric matrix, a list of matrices, or \code{NULL}. } \description{ Extract a genotype matrix from an object that carries genotype - 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). + data. For a \code{QtlDataset}, the whole dataset's dosages (samples x + variants), with no QC applied: to read part of it, narrow the dataset + first, e.g. \code{genotypes(x[window, samples, ])}. } \examples{ data(qtlDatasetExample) diff --git a/man/gwasSumStatsS4Example.Rd b/man/gwasSumStatsS4Example.Rd index 7713f742..a06c86f2 100644 --- a/man/gwasSumStatsS4Example.Rd +++ b/man/gwasSumStatsS4Example.Rd @@ -13,8 +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{ldReference} slot references the same toy PLINK1 panel used -for the QTL example. +Its LD reference is the same toy PLINK1 panel the QTL example uses. } \examples{ data(gwasSumStatsS4Example) diff --git a/man/intersectVariants.Rd b/man/intersectVariants.Rd index 4a23b7de..df811b35 100644 --- a/man/intersectVariants.Rd +++ b/man/intersectVariants.Rd @@ -31,8 +31,8 @@ Restrict two fine-mapping collections to the variants they have variants that survive. } \details{ -\code{subsetRegion()} restricts ONE object to a window; this - intersects TWO objects against each other. Coloc needs it symmetric -- +This intersects two objects against each other. Coloc needs it + symmetric -- both sides must be scored on the same variant set -- while TWAS, MR and cTWAS need it one-sided, adjusting the QTL side to the GWAS variant set and leaving the GWAS side alone. diff --git a/man/lassosumRss.Rd b/man/lassosumRss.Rd index aa161085..d549860e 100644 --- a/man/lassosumRss.Rd +++ b/man/lassosumRss.Rd @@ -22,7 +22,7 @@ it before passing (e.g., \code{(1-s)*R + s*I}).} \item{n}{Sample size of the GWAS.} -\item{lambda}{A vector of L1 penalty values. Default: 20 values from 0.001 to +\item{lambda}{A vector of L1 penalty values. Default: 20 values from 1e-4 to 0.1 on log scale.} \item{thr}{Convergence threshold. Default: 1e-4.} @@ -47,7 +47,10 @@ 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. +summary statistics", Genetic Epidemiology 41(6):469-480. It runs on the +solver of \code{\link{penalizedRss}}, whose LASSO at \code{alpha = 1} is +lassosum's coordinate descent: the same updates in the same order, so the +same coefficients bit for bit. Internal: \code{\link{lassosumRssWeights}} is the public interface. It runs this over a grid of LD shrinkage values, forwards \code{lambda}, diff --git a/man/lbf.Rd b/man/lbf.Rd index 76538fc7..1086e142 100644 --- a/man/lbf.Rd +++ b/man/lbf.Rd @@ -15,12 +15,13 @@ lbf(x, ...) \item{...}{Ignored.} } \value{ -A \code{tibble}: \code{variant_id} + \code{lbf_L1..lbf_LL} (the - collection method also carries the entry identity columns). +A \code{GRanges}, one range per variant, whose \code{mcols()} + hold \code{variant_id} + \code{lbf_L1..lbf_LL} (the collection method + also carries the entry identity columns). } \description{ The variant x effect matrix of single-effect log Bayes factors -(\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row +(\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one range per variant, one \code{lbf_L} column per effect. The per-variant scalar summary (max across effects) is the \code{logBF} column of \code{\link{topLoci}}; this accessor keeps the full per-effect breakdown. diff --git a/man/ldClumpByScore.Rd b/man/ldClumpByScore.Rd index 767a9ff6..b8e43c22 100644 --- a/man/ldClumpByScore.Rd +++ b/man/ldClumpByScore.Rd @@ -24,7 +24,7 @@ which case bigsnpr falls back to minor allele frequency computed from \code{X}.} \item{chr}{Integer or character vector of length \code{ncol(X)} giving the -chromosome for each variant.} +chromosome for each variant, in any style (\code{"chr1"} or \code{1}).} \item{pos}{Integer vector of length \code{ncol(X)} giving the base-pair position for each variant.} diff --git a/man/ldMatrix.Rd b/man/ldMatrix.Rd index 5f804144..f649cc31 100644 --- a/man/ldMatrix.Rd +++ b/man/ldMatrix.Rd @@ -3,25 +3,33 @@ \name{ldMatrix} \alias{ldMatrix} \alias{ldMatrix,LdMatrix-method} +\alias{as.matrix,LdMatrix-method} +\alias{coerce,LdMatrix,matrix-method} \title{Get LD Correlation Matrix} \usage{ ldMatrix(x) \S4method{ldMatrix}{LdMatrix}(x) + +\S4method{as.matrix}{LdMatrix}(x, ...) } \arguments{ \item{x}{An \code{LdMatrix}.} + +\item{...}{Unused.} } \value{ A correlation matrix. } \description{ Extract the LD correlation matrix an \code{\link{LdMatrix}} - holds, labelled by its variant ids. + holds, labelled by its variant ids. \code{as.matrix(x)} and + \code{as(x, "matrix")} return the same matrix. } \examples{ data(eqtlRegionExample) X <- eqtlRegionExample$X[, 1:8] ld <- LdMatrix(cor(X), nSamples = nrow(X)) ldMatrix(ld)[1:3, 1:3] +identical(as.matrix(ld), ldMatrix(ld)) } diff --git a/man/ldReference.Rd b/man/ldReference.Rd index a4c7321a..1a084671 100644 --- a/man/ldReference.Rd +++ b/man/ldReference.Rd @@ -1,11 +1,12 @@ % 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 +% R/ColocResult.R, R/ColocBoostResult.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,ColocResult-method} +\alias{ldReference,ColocBoostResult-method} \alias{ldReference,LdStatistic-method} \alias{ldReference,TwasWeights-method} \title{Get LD Reference} @@ -16,7 +17,9 @@ ldReference(x, ...) \S4method{ldReference}{FineMappingResultBase}(x) -\S4method{ldReference}{ColocResultBase}(x) +\S4method{ldReference}{ColocResult}(x) + +\S4method{ldReference}{ColocBoostResult}(x) \S4method{ldReference}{LdStatistic}(x) @@ -28,22 +31,31 @@ ldReference(x, ...) \item{...}{Unused.} } \value{ -A \code{RangedSummarizedExperiment} genotype panel, a +A named list of LD references; for an \code{LdStatistic}, 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). +Return the LD references of this object, each a genotype + panel (see \code{\link{readGenotypes}}), a \code{\link{GenotypeMixture}} + or an \code{\link{LdMatrix}}. + + The collections whose rows can sit on different references -- + \code{GwasSumStats}, \code{QtlSumStats}, \code{FineMappingResultBase}, + \code{TwasWeights}, \code{ColocResult} and \code{ColocBoostResult} -- + return a named list holding each distinct reference their rows use, once. + The \code{ldReference} column of their \code{mcols} (of + \code{outcomeInfo} for a \code{ColocBoostResult}) names the entry each + row used, \code{NA} for one fit without LD (e.g. a \code{TwasWeights} + row learned from individual-level data via \code{QtlDataset}). The list + is empty when no row has a reference. + + An \code{LdStatistic} returns the one panel it reads its blocks' LD from, + or \code{NULL} when it was built from \code{LdMatrix} blocks. } \examples{ data(qtlSumStatsExample) +# One entry per distinct reference; each row names its own. ldReference(qtlSumStatsExample) +qtlSumStatsExample$ldReference } diff --git a/man/learnTwasWeights.Rd b/man/learnTwasWeights.Rd index bcfd675a..3841c7c4 100644 --- a/man/learnTwasWeights.Rd +++ b/man/learnTwasWeights.Rd @@ -11,7 +11,7 @@ learnTwasWeights( studyName = "", context = "", trait = "", - numThreads = 1, + BPPARAM = SerialParam(), fittedModels = NULL, fitRetention = c("none", "slim", "full"), weightStandardized = FALSE, @@ -44,10 +44,11 @@ weights.} \item{trait}{Character. Trait identity label recorded on the resulting weights.} -\item{numThreads}{The number of threads to use for parallel processing. If -set to -1, the function uses all available cores. If set to 0 or 1, no -parallel processing is performed. If set to 2 or more, parallel processing -is enabled with that many threads.} +\item{BPPARAM}{A \code{BiocParallelParam} the methods run on; +\code{SerialParam()} (default) runs them one at a time. Each draws from +its own random-number stream, seeded by \code{seed}, else by the param's +own \code{RNGseed}, else by one draw from the session RNG, so a run +gives the same numbers however many workers it has.} \item{fittedModels}{Named list of fitted SuSiE-family models, keyed by token (\code{susie}, \code{susieInf}, \code{mvsusie}, \code{fsusie}). @@ -77,10 +78,9 @@ messages, 1 = suppress external package messages (default), 2 = show all messages including those from external packages.} \item{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 +RNG and the streams the methods draw from (see \code{BPPARAM}). The main-process seed is scoped to the call, so the session RNG is left as it -was found. \code{NULL} (default) does not seed at all.} +was found. \code{NULL} (default) seeds neither.} } \value{ A list where each element is named after a method and contains the diff --git a/man/loadGenotypeRegion.Rd b/man/loadGenotypeRegion.Rd index fead0e4f..b961008c 100644 --- a/man/loadGenotypeRegion.Rd +++ b/man/loadGenotypeRegion.Rd @@ -6,7 +6,7 @@ \usage{ loadGenotypeRegion( genotype, - region = NULL, + which = NULL, keepIndel = TRUE, keepVariantsPath = NULL, returnVariantInfo = FALSE, @@ -17,7 +17,8 @@ loadGenotypeRegion( \arguments{ \item{genotype}{Path to the genotype data file, or a PLINK prefix.} -\item{region}{The target region in the format "chr:start-end".} +\item{which}{Optional \code{GRanges}: load only the variants that overlap +it. If NULL, loads every variant.} \item{keepIndel}{Whether to keep indel SNPs.} @@ -51,5 +52,6 @@ dosages are automatically rescaled using the stored U_MIN/U_MAX values. \examples{ stem <- sub("[.]bed$", "", system.file("extdata", "toy_ref.bed", package = "pecotmr")) -loadGenotypeRegion(genotype = stem, region = "chr22:1-100000000") +loadGenotypeRegion(genotype = stem, + which = GenomicRanges::GRanges("chr22:1-100000000")) } diff --git a/man/loadGwasSumStatsFromManifest.Rd b/man/loadGwasSumStatsFromManifest.Rd index fbedf58b..49577d6c 100644 --- a/man/loadGwasSumStatsFromManifest.Rd +++ b/man/loadGwasSumStatsFromManifest.Rd @@ -8,34 +8,48 @@ loadGwasSumStatsFromManifest( manifest, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, - formatMapping = NULL, - ldBlocks = NULL + formatMapping = NULL ) } \arguments{ \item{manifest}{A data.frame or path. Columns (snake_case aliases accepted): \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{ldReferencePath}. When a row +\code{nSample} (optional study-level total N), \code{varY} (optional), the +single-valued \code{genome}, and \code{ldReferencePath}, which may differ +between studies (each distinct reference is read once, for the +chromosomes its studies cover, and stored once). 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.} +\code{\link{summaryStatsQc}} fills \code{N} from the scalar. Optional +BED-style \code{chrom}/\code{start}/\code{end} columns, with a 0-based +\code{start} as in BED, give each study its own window, read and kept as +with \code{which}; a manifest that has them cannot also be given +\code{which}.} \item{genome}{Genome build; reconciled with a \code{genome} column.} \item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) or a -spec (path/prefix/genoMeta); reconciled with an \code{ldReferencePath} -column.} +spec (path/prefix/genoMeta), used for every study; where a row also names +an \code{ldReferencePath} the two must agree. Omit it to give each study +the reference its \code{ldReferencePath} names.} -\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{which}{Optional analysis windows shared by every study, typically +LD blocks: a \code{GRanges}, or the path of a BED file, read as BED +with a 0-based start. Only the variants inside them are read, when the +file is tabix-indexed text or a bgzipped + tabixed VCF (otherwise the +whole file is read, with a warning), and each study is split into one +element per window it has variants in, each window recorded as that +element's \code{region}, as \code{\link{GwasSumStats}} does with its +\code{region}; a named \code{GRanges} names the blocks. Without +windows a genome-wide file splits +into one element per chromosome; split by LD block, it has the +granularity \code{\link{assembleCtwasInputs}} needs.} \item{minLdOverlapWarn}{Warn when the fraction of sumstats variants present in the LD reference falls below this (default 0.5).} @@ -48,22 +62,16 @@ 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 (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.} } \value{ A \code{GwasSumStats} object. } \description{ Build a \code{\link{GwasSumStats}} from a manifest with one row - per study. No QC is run (the result carries \code{qcInfo = list()}). Each - sumstats file needs a \code{z} column, or \code{beta}+\code{se} from which - the Wald z (\code{z = beta/se}) is derived when \code{z} is absent (a - supplied \code{z} takes precedence). + per study. No QC is run (the result carries empty \code{qcOptions()}). + Each sumstats file needs a \code{z} column, or \code{beta}+\code{se} from + which the Wald z (\code{z = beta/se}) is derived when \code{z} is absent + (a supplied \code{z} takes precedence). } \examples{ gwasTsv <- system.file("extdata", "manifests", @@ -72,5 +80,6 @@ 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", - ldReference = ldStem, region = "chr22:10000000-19000000") + ldReference = ldStem, + which = GenomicRanges::GRanges("chr22:10000000-19000000")) } diff --git a/man/loadMultiStudyQtlDatasetFromManifest.Rd b/man/loadMultiStudyQtlDatasetFromManifest.Rd index 72863db6..917da313 100644 --- a/man/loadMultiStudyQtlDatasetFromManifest.Rd +++ b/man/loadMultiStudyQtlDatasetFromManifest.Rd @@ -9,14 +9,12 @@ loadMultiStudyQtlDatasetFromManifest( sumStatsManifest = NULL, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, formatMapping = NULL, - transposeCovariates = FALSE, - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam() + transposeCovariates = FALSE ) } \arguments{ @@ -27,20 +25,13 @@ loadMultiStudyQtlDatasetFromManifest( \item{sumStatsManifest}{Optional QtlSumStats manifest (see \code{\link{loadQtlSumStatsFromManifest}}).} -\item{genome, ldReference, region, minLdOverlapWarn}{Passed to the QtlSumStats +\item{genome, ldReference, which, minLdOverlapWarn}{Passed to the QtlSumStats loader for \code{sumStatsManifest}.} \item{columnMapping, sampleSelect, formatMapping}{Passed to the QtlSumStats loader for \code{sumStatsManifest}.} \item{transposeCovariates}{Transpose covariate TSVs (QTLtools layout).} - -\item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument, -applied to every study.} - -\item{genotypeFilterParam}{Pass-through \code{\link{QtlDataset}} filtering -options, built with \code{\link{GenotypeFilterParam}} and applied to -every study.} } \value{ A \code{MultiStudyQtlDataset} object. diff --git a/man/loadQtlDatasetFromManifest.Rd b/man/loadQtlDatasetFromManifest.Rd index 0283d9bb..876ff32e 100644 --- a/man/loadQtlDatasetFromManifest.Rd +++ b/man/loadQtlDatasetFromManifest.Rd @@ -9,8 +9,6 @@ loadQtlDatasetFromManifest( studyName = NULL, genotypes = NULL, genotypeCovariates = NULL, - scaleResiduals = TRUE, - genotypeFilterParam = GenotypeFilterParam(), transposeCovariates = FALSE ) } @@ -30,12 +28,6 @@ a genotype path/prefix; reconciled with a \code{genotypePath} column.} \item{genotypeCovariates}{A numeric matrix (samples x covariates) or a path to a covariate TSV; reconciled with a \code{genotypeCovariatePath} column.} -\item{scaleResiduals}{Pass-through \code{\link{QtlDataset}} argument.} - -\item{genotypeFilterParam}{Pass-through \code{\link{QtlDataset}} filtering -options, built with \code{\link{GenotypeFilterParam}} and stored as lazy -QC slots.} - \item{transposeCovariates}{Transpose covariate TSVs (QTLtools layout) before treating them as samples-as-rows.} } diff --git a/man/loadQtlSumStatsFromManifest.Rd b/man/loadQtlSumStatsFromManifest.Rd index d3900b65..d5bfc04d 100644 --- a/man/loadQtlSumStatsFromManifest.Rd +++ b/man/loadQtlSumStatsFromManifest.Rd @@ -8,7 +8,7 @@ loadQtlSumStatsFromManifest( manifest, genome = NULL, ldReference = NULL, - region = NULL, + which = NULL, minLdOverlapWarn = 0.5, columnMapping = NULL, sampleSelect = NULL, @@ -21,26 +21,44 @@ loadQtlSumStatsFromManifest( \item{manifest}{A data.frame or path. Columns (snake_case aliases accepted): \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{ldReferencePath}. When a row supplies \code{nSample}, +tuple-level total N), \code{varY} (optional), the single-valued +\code{genome}, and \code{ldReferencePath}, which may differ between rows +(each distinct reference is read once, for the chromosomes its rows +cover, and stored once). 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.)} +QTL traits are quantitative.) Optional BED-style +\code{chrom}/\code{start}/\code{end} columns, with a 0-based +\code{start} as in BED, give each tuple its own window, read and kept as +with \code{which}; a manifest that has them cannot also be given +\code{which}. Optional \code{traitStart}/\code{traitEnd} columns, on +the row's \code{chrom} and 0-based the same way, give the trait's +position (\code{traitPos}).} \item{genome}{Genome build; reconciled with a \code{genome} column.} \item{ldReference}{A genotype panel (see \code{\link{readGenotypes}}) or -spec; reconciled with an \code{ldReferencePath} column.} +spec, used for every row; where a row also names an +\code{ldReferencePath} the two must agree. Omit it to give each row the +reference its \code{ldReferencePath} names.} -\item{region, minLdOverlapWarn, columnMapping, sampleSelect, formatMapping}{As -for \code{\link{loadGwasSumStatsFromManifest}}.} +\item{which}{Optional analysis window shared by every tuple: a +\code{GRanges}, or the path of a BED file, read as BED with a 0-based +start. One window only, since a tuple has one: tuples with windows +of their own give them in the manifest's columns. Only the variants +inside it are read, when the file is tabix-indexed (otherwise the whole +file is read, with a warning), and it is each tuple's \code{region} (see +\code{\link{QtlSumStats}}).} + +\item{minLdOverlapWarn, columnMapping, sampleSelect, formatMapping}{As for +\code{\link{loadGwasSumStatsFromManifest}}.} \item{traitColumn}{Optional column of the sumstats file naming the trait of each row (e.g. \code{"molecular_trait_id"} in a cis-QTL scan, which writes every gene into one table). When set, each manifest row keeps only the rows whose \code{traitColumn} equals that row's \code{trait}. Without it -a multi-trait file loads whole, since \code{region} restriction needs a +a multi-trait file loads whole, since \code{which} restriction needs a tabix index and neighbouring cis windows overlap regardless.} \item{variantIdAlleles}{Where to find the alleles when the file has no @@ -72,5 +90,6 @@ 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", - ldReference = ldStem, region = "chr22:10000000-19000000") + ldReference = ldStem, + which = GenomicRanges::GRanges("chr22:10000000-19000000")) } diff --git a/man/maf.Rd b/man/maf.Rd index 2289830d..4ba6a564 100644 --- a/man/maf.Rd +++ b/man/maf.Rd @@ -8,22 +8,15 @@ \usage{ maf(x, ...) -\S4method{maf}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{maf}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) -\S4method{maf}{QtlDataset}(x, region = NULL, cisWindow = NULL, samples = NULL) +\S4method{maf}{QtlDataset}(x) } \arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlDataset} object.} +\item{x}{A \code{GwasSumStats}, \code{QtlSumStats} or \code{QtlDataset} +object.} -\item{...}{Class-specific selection arguments (e.g., \code{region}, -\code{cisWindow} for \code{QtlDataset}).} +\item{...}{Class-specific selection arguments.} \item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection to this study; \code{NULL} matches all studies.} @@ -33,28 +26,15 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} - -\item{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.} - -\item{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window -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.} } \value{ Numeric vector of MAFs, or NULL if not available. } \description{ -Extract MAF vector from a GwasSumStats object. +Extract the minor-allele-frequency vector from one entry of + a summary-statistic collection, or from a \code{QtlDataset} over the + whole dataset (narrow it first, with \code{x[i, j, ]}, to read part of + it). } \examples{ data(qtlDatasetExample) diff --git a/man/marginalEffects.Rd b/man/marginalEffects.Rd index 18ab81e4..ae505550 100644 --- a/man/marginalEffects.Rd +++ b/man/marginalEffects.Rd @@ -5,24 +5,20 @@ \alias{marginalEffects,FineMappingResultBase-method} \title{Get Marginal Effects} \usage{ -marginalEffects(x, maxPval = NULL, ...) +marginalEffects(x, ...) \S4method{marginalEffects}{FineMappingResultBase}( x, - maxPval = NULL, studyName = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) } \arguments{ \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).} - \item{...}{Class-specific selection arguments.} \item{studyName}{Character (length 1) or \code{NULL}. Restrict the selection @@ -37,19 +33,21 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} } \value{ -A \code{data.frame}. +A \code{GRanges}, one range per variant; when the selectors match + more than one entry the row-identity columns are carried in + \code{mcols()} too. } \description{ Extract per-variant marginal univariate effects from a - fine-mapping entry or result. Returns a \code{data.frame} with identity - 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. + fine-mapping entry or result, one range per variant. Its \code{mcols()} + hold the identity 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. } \examples{ data(qtlFineMappingExample) diff --git a/man/mashInput.Rd b/man/mashInput.Rd index 22fbd218..dc18ac62 100644 --- a/man/mashInput.Rd +++ b/man/mashInput.Rd @@ -22,7 +22,8 @@ mashInput( 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).} +run (the matrix builder rejects un-QC'd SumStats). The conditions are a +QTL object's contexts and a GWAS object's studies.} \item{nRandom, nNull}{Per-object random / null sample sizes (default 10 each).} diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index 12761975..6189a018 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -33,7 +33,9 @@ standardized genotypes, never formed as a matrix.} \item{gamma}{MCP concavity parameter. Default 3.} -\item{alpha}{Elastic-net mixing (1 = pure L1). Default 1.} +\item{alpha}{Elastic-net mixing in \code{(0, 1]}: the MCP share of +the penalty, the rest a ridge term, as \code{\link{penalizedRss}} +mixes them. Default 1, no ridge term.} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} diff --git a/man/mergeCtwasBoundaryRegions.Rd b/man/mergeCtwasBoundaryRegions.Rd index ef516588..b273d365 100644 --- a/man/mergeCtwasBoundaryRegions.Rd +++ b/man/mergeCtwasBoundaryRegions.Rd @@ -10,7 +10,7 @@ mergeCtwasBoundaryRegions( filterCs = FALSE, maxSNP = Inf, maxNumSingleEffects = 5L, - numThreads = 1L, + BPPARAM = SerialParam(), methodArgs = CtwasOptions() ) } @@ -36,7 +36,10 @@ to be selected (\code{select_boundary_genes} \code{filter_cs}). Default \item{maxNumSingleEffects}{Integer. Max number of single effects for the merged-region re-fine-mapping (LD path only). Default \code{5}.} -\item{numThreads}{Number of cores. Default \code{1}.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the cores +ctwas's own \code{ncore} parallelism uses when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +core. Default \code{SerialParam()}.} \item{methodArgs}{Additional arguments forwarded to ctwas, built with \code{\link{CtwasOptions}}. Names are checked against what diff --git a/man/molecularTraits.Rd b/man/molecularTraits.Rd index 7cd247dc..1c80a3a4 100644 --- a/man/molecularTraits.Rd +++ b/man/molecularTraits.Rd @@ -7,49 +7,22 @@ \usage{ molecularTraits(x, ...) -\S4method{molecularTraits}{QtlDataset}( - x, - contexts, - traitId = NULL, - region = NULL, - naAction = c("keep", "drop", "impute"), - outlierAction = c("keep", "drop"), - outlierPvalThreshold = 0.001, - outlierArgs = CovMcdOptions() -) +\S4method{molecularTraits}{QtlDataset}(x, context, trait = NULL) } \arguments{ \item{x}{The object to extract from.} -\item{...}{Class-specific selection arguments (e.g., \code{contexts}, -\code{traitId}, \code{region}).} +\item{...}{Class-specific selection arguments (e.g., \code{context}, +\code{trait}).} -\item{contexts}{Character vector. Context(s) whose data to extract.} +\item{context}{Character vector. Context(s) whose data to extract.} -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier +\item{trait}{Character or \code{NULL}. Molecular trait / feature identifier to select; \code{NULL} matches all traits in the dataset.} - -\item{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.} - -\item{naAction}{Character. How to handle missing phenotype values: one of -\code{"keep"}, \code{"drop"}, or \code{"impute"}.} - -\item{outlierAction}{Character. How to handle phenotype outliers: one of -\code{"keep"} or \code{"drop"}.} - -\item{outlierPvalThreshold}{Numeric. Two-sided p-value threshold for flagging -phenotype outliers. Default \code{1e-3}.} - -\item{outlierArgs}{Extra arguments for \code{robustbase::covMcd()}, the -robust covariance estimator the outlier rule is built on, supplied with -\code{\link{CovMcdOptions}} -- \code{alpha} in particular. Only -consulted when \code{outlierAction = "drop"}.} } \value{ -A \code{SummarizedExperiment} when one context is selected, or a - named list of them for several. A \code{QtlDataset} is a +A named list of \code{SummarizedExperiment}s keyed by context, + one per selected context. A \code{QtlDataset} is a \code{MultiAssayExperiment}, so these are its experiments; take the measurement matrix itself with \code{SummarizedExperiment::assay()} rather than asking this accessor @@ -57,11 +30,12 @@ A \code{SummarizedExperiment} when one context is selected, or a } \description{ Extract molecular-trait data from an object that carries it. - For a \code{QtlDataset}, the user can optionally select specific contexts, - traits, or a region (see method documentation for the per-class selection - arguments). + For a \code{QtlDataset}, select contexts and, optionally, traits by + name. The data come back as stored: missing values and outliers are a + run's phenotype QC (\code{\link{PhenotypeFilterParam}}), applied by the + pipelines, not by this accessor. } \examples{ data(qtlDatasetExample) -molecularTraits(qtlDatasetExample, contexts = "brain") +molecularTraits(qtlDatasetExample, context = "brain") } diff --git a/man/mrmashWrapper.Rd b/man/mrmashWrapper.Rd index c27bce1d..40f88eb9 100644 --- a/man/mrmashWrapper.Rd +++ b/man/mrmashWrapper.Rd @@ -15,7 +15,7 @@ mrmashWrapper( updateV = TRUE, updateVMethod = "full", standardize = FALSE, - numThreads = 1, + BPPARAM = SerialParam(), methodArgs = MrmashOptions() ) } @@ -53,8 +53,12 @@ data. Default is FALSE. Used by the summary-statistic and initialisation steps as well as the fit, so it is set here rather than in \code{methodArgs}.} -\item{numThreads}{The number of threads to use for parallel computation. -Default is 1. Used by the same three steps as \code{standardize}.} +\item{BPPARAM}{A \code{BiocParallelParam}. The univariate glmnet fits that +initialise the coefficients run on its workers, and mr.mash's own +threads (the summary statistics and the fit) number its workers when +they run on this machine (\code{SerialParam}, \code{MulticoreParam}); +for other backends mr.mash runs on one thread. Default +\code{SerialParam()}.} \item{methodArgs}{Options forwarded to \code{mr.mashr::mr.mash} under its own names, built with \code{\link{MrmashOptions}} diff --git a/man/nSamples.Rd b/man/nSamples.Rd index 0f1fa66d..a3dbb4c1 100644 --- a/man/nSamples.Rd +++ b/man/nSamples.Rd @@ -1,59 +1,32 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/LdMatrix.R, -% R/GenotypeHandle.R, R/AllClasses.R +% R/GenotypeHandle.R \name{nSamples} \alias{nSamples} \alias{nSamples,LdMatrix-method} \alias{nSamples,GenotypeHandle-method} -\alias{nSamples,SumStatsBase-method} -\title{Get Sample Sizes} +\title{Get the Number of Reference Samples} \usage{ nSamples(x, ...) \S4method{nSamples}{LdMatrix}(x, ...) \S4method{nSamples}{GenotypeHandle}(x) - -\S4method{nSamples}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) } \arguments{ -\item{x}{A \code{GwasSumStats}, \code{QtlSumStats}, \code{LdMatrix} or -\code{GenotypeHandle} object.} +\item{x}{An \code{LdMatrix} or \code{GenotypeHandle} object.} \item{...}{Class-specific selection arguments.} - -\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.} - -\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to -this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -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} or an \code{LdMatrix} - (\code{NA} when the matrix records no size). +An integer of length 1 (\code{NA} when an \code{LdMatrix} 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, the number of samples carried by a \code{GenotypeHandle}, or the - panel size an \code{\link{LdMatrix}} records. +The number of samples an LD reference was built from: the + samples carried by a \code{GenotypeHandle}, or the panel size an + \code{\link{LdMatrix}} records. The per-variant sample size of summary + statistics is \code{\link{sampleSize}}. } \details{ The genotype handle is the seed layer behind a panel and is not @@ -61,6 +34,7 @@ The genotype handle is the seed layer behind a panel and is not \code{readGenotypes()} and ask it directly. } \examples{ -data(qtlSumStatsExample) -nSamples(qtlSumStatsExample) +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:8] +nSamples(LdMatrix(cor(X), nSamples = nrow(X))) } diff --git a/man/nSnps.Rd b/man/nSnps.Rd index 8eddf55f..19f208c3 100644 --- a/man/nSnps.Rd +++ b/man/nSnps.Rd @@ -8,14 +8,7 @@ \usage{ nSnps(x, ...) -\S4method{nSnps}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{nSnps}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) \S4method{nSnps}{H2Estimate}(x) } @@ -33,12 +26,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Integer. diff --git a/man/nestTupleRanges.Rd b/man/nestTupleRanges.Rd index 54d19155..97f02e66 100644 --- a/man/nestTupleRanges.Rd +++ b/man/nestTupleRanges.Rd @@ -18,7 +18,8 @@ An object of \code{template}'s class. } \description{ The inverse of \code{\link{flattenTupleRanges}}: ranges are grouped by the -identity tuple they carry and returned to \code{template}'s elements, so the +identity tuple they carry -- and, for a tuple split across chromosomes, by +chromosome -- and returned to \code{template}'s elements, so the collection's class, its per-element payloads and its collection-level slots all survive a plyranges round trip. } diff --git a/man/normalizeVariantId.Rd b/man/normalizeVariantId.Rd index 1b11216c..1bf84b29 100644 --- a/man/normalizeVariantId.Rd +++ b/man/normalizeVariantId.Rd @@ -9,8 +9,10 @@ normalizeVariantId(ids, chrPrefix = TRUE, convention = NULL) \arguments{ \item{ids}{A character vector of variant IDs in any supported format.} -\item{chrPrefix}{Logical, whether to include "chr" prefix. Default TRUE. -Ignored if \code{convention} is provided.} +\item{chrPrefix}{Logical. \code{TRUE} (default) writes the chromosome in +UCSC style (\code{chr1}, \code{chrM}), the style pecotmr uses +throughout; \code{FALSE} writes it bare. Ignored if \code{convention} is +provided.} \item{convention}{Optional list from \code{detectVariantConvention} or \code{attr(parseVariantId(ids), "convention")}. When provided, the output diff --git a/man/overlapTopLoci.Rd b/man/overlapTopLoci.Rd index e78c0e9b..8a2ecda3 100644 --- a/man/overlapTopLoci.Rd +++ b/man/overlapTopLoci.Rd @@ -23,7 +23,9 @@ inputs. Default 0.025.} A \code{GRanges} keyed on the QTL variant (\code{variant_id, chrom, pos, A1, A2} in \code{mcols()}) with all other columns prefixed \code{qtl_} / \code{gwas_}. Zero ranges when there is no - allele-aware overlap. Take a table with \code{as.data.frame()}. + allele-aware overlap. Take a table with \code{as.data.frame()}. Its + \code{seqinfo()} names the genome build the two results name; results + naming different builds are refused. } \description{ Intersect the top-loci tables of a \code{QtlFineMappingResult} and a diff --git a/man/parseRegion.Rd b/man/parseRegion.Rd deleted file mode 100644 index b011a737..00000000 --- a/man/parseRegion.Rd +++ /dev/null @@ -1,24 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{parseRegion} -\alias{parseRegion} -\title{Parse a region string into its components} -\usage{ -parseRegion(region) -} -\arguments{ -\item{region}{A single region string.} -} -\value{ -A vector/list with the chromosome, start and end, or the input - unchanged when it is not a scalar string. -} -\description{ -Split a region identifier (e.g. \code{"chr1:100-200"} or -\code{"chr1_100_200"}) into chromosome, start and end. Non-character or -non-scalar input is returned unchanged. -} -\examples{ -parseRegion("chr1:1000000-2000000") -parseRegion("chr1_1000000_2000000") -} diff --git a/man/parseVariantId.Rd b/man/parseVariantId.Rd index e1882c3f..fe9dc2ca 100644 --- a/man/parseVariantId.Rd +++ b/man/parseVariantId.Rd @@ -12,18 +12,19 @@ parseVariantId(ids) layout).} } \value{ -A tibble with columns "chrom" (character, normalized), "pos" +A tibble with columns "chrom" (character, UCSC style), "pos" (integer), "A2" (character), "A1" (character). The detected convention is stored as \code{attr(result, "convention")}. } \description{ Converts variant IDs from any supported string format or data.frame into a -standardized data.frame with a normalized character chrom, integer pos, and -character allele columns (A2, A1). The chrom is canonicalized (chr stripped, -uppercased, 23 -> X / 24 -> Y / M -> MT) but kept as a string so X/Y/MT -survive. Supports colon-separated ("chr1:100:A:G"), underscore-separated -("1_100_A_G"), with or without "chr" prefix, and with optional build suffix -(":b38" or "_b38"). The detected input convention is stored as an attribute. +standardized data.frame with a character chrom, integer pos, and character +allele columns (A2, A1). The chrom is spelled in UCSC style, as every +chromosome pecotmr holds is ("chr1", "chrX", "chrM"; 23 -> chrX, +24 -> chrY). Supports colon-separated ("chr1:100:A:G"), +underscore-separated ("1_100_A_G"), with or without "chr" prefix, and with +optional build suffix (":b38" or "_b38"). The detected input convention is +stored as an attribute. } \examples{ parseVariantId(c("chr1:100:A:G", "chr2:200:T:C")) diff --git a/man/pecotmr-gwas-sumstats.Rd b/man/pecotmr-gwas-sumstats.Rd index 3da781ac..a2178535 100644 --- a/man/pecotmr-gwas-sumstats.Rd +++ b/man/pecotmr-gwas-sumstats.Rd @@ -4,7 +4,8 @@ \alias{pecotmr-gwas-sumstats} \title{GWAS Summary Statistics Handling} \description{ -Constructor, accessors, and converters for \code{GwasSumStats} - (the post-refactor DFrame-subclass collection keyed by \code{study}). +Constructor, accessors, and converters for + \code{GwasSumStats}, the \code{RangedTupleList} collection of GWAS + summary statistics keyed by \code{study}. } \keyword{internal} diff --git a/man/pecotmr-qtl-sumstats.Rd b/man/pecotmr-qtl-sumstats.Rd index 47020696..07f09354 100644 --- a/man/pecotmr-qtl-sumstats.Rd +++ b/man/pecotmr-qtl-sumstats.Rd @@ -5,6 +5,7 @@ \title{QTL Summary Statistics Handling} \description{ Constructor and accessor methods for \code{QtlSumStats}, the - DFrame-subclass collection keyed by \code{(study, context, trait)}. + \code{RangedTupleList} collection keyed by \code{(study, context, + trait)}. } \keyword{internal} diff --git a/man/penalizedRss.Rd b/man/penalizedRss.Rd index 4acb4b81..cf7af3b7 100644 --- a/man/penalizedRss.Rd +++ b/man/penalizedRss.Rd @@ -9,7 +9,7 @@ penalizedRss( R, n, penalty = c("lasso", "MCP", "SCAD", "L0", "L0L1", "L0L2"), - lambda = exp(seq(log(1e-04), log(0.1), length.out = 20)), + lambda = NULL, gamma = NULL, alpha = 1, lambda0 = 0, @@ -33,13 +33,19 @@ window), as in \code{lassosumRss()}.} \item{lambda}{Numeric vector of regularization parameter values along which to trace a solution path (warm-started, largest-first). For LASSO/MCP/SCAD this is the primary penalty strength; for L0 variants it controls the L1 -component.} +component. \code{NULL} (default) is 20 values from 1e-4 to 0.1 on a log +scale, divided by \code{max(alpha, 0.001)} as glmnet sizes its path, so +the L1 share spans the same range at any \code{alpha} and a ridge path +runs from 0.1 to 100.} \item{gamma}{Concavity parameter for MCP (default 3) or SCAD (default 3.7). Ignored for LASSO and L0 variants.} -\item{alpha}{Elastic-net mixing for MCP/SCAD: \eqn{l_1 = \lambda \alpha}, -\eqn{l_2 = \lambda (1-\alpha)}. Default 1 (pure L1, no ridge).} +\item{alpha}{Elastic-net mixing for LASSO, MCP and SCAD, in \code{[0, 1]}: +\eqn{l_1 = \lambda \alpha} and \eqn{l_2 = \lambda (1-\alpha)}, so the +penalty is \eqn{2 P(\beta; l_1) + l_2 \beta^T \beta}, glmnet's mixing. +Default 1, no ridge term. For LASSO, 0.5 is the elastic net and 0 ridge; +MCP and SCAD need \code{alpha > 0}. Ignored by the L0 variants.} \item{lambda0}{L0 penalty weight (number of non-zeros). Required for L0 variants; ignored otherwise. Default 0.} @@ -67,14 +73,16 @@ A list with components: } } \description{ -Generalizes \code{lassosumRss()} to support LASSO, MCP, SCAD, L0, L0L1, -and L0L2 penalties. Uses coordinate descent on the objective +The RSS penalized-regression solver: LASSO with its elastic-net and ridge +mixtures, MCP, SCAD, L0, L0L1 and L0L2. Uses coordinate descent on the +objective \deqn{\beta^T R \beta - 2 \beta^T z + \mathrm{penalty}(\beta)} where \eqn{R} is a (possibly pre-shrunk) LD matrix and \eqn{z = \hat\beta / -\sqrt{n}}. +\sqrt{n}}. \code{lassosumRss()} is its LASSO at \code{alpha = 1}. } \details{ -Internal: \code{\link{scadRssWeights}}, \code{\link{mcpRssWeights}} and +Internal: \code{\link{enetRssWeights}}, \code{\link{ridgeRssWeights}}, +\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 diff --git a/man/phenotypeCovariates.Rd b/man/phenotypeCovariates.Rd index 9b15eec0..9ef32c2d 100644 --- a/man/phenotypeCovariates.Rd +++ b/man/phenotypeCovariates.Rd @@ -5,14 +5,14 @@ \alias{phenotypeCovariates,QtlDataset-method} \title{Get Per-Context Phenotype Covariates} \usage{ -phenotypeCovariates(x, contexts) +phenotypeCovariates(x, context) -\S4method{phenotypeCovariates}{QtlDataset}(x, contexts) +\S4method{phenotypeCovariates}{QtlDataset}(x, context) } \arguments{ \item{x}{A \code{QtlDataset} object.} -\item{contexts}{Character vector of context names (subset of +\item{context}{Character vector of context names (subset of \code{names(molecularTraits(x))}).} } \value{ @@ -24,5 +24,5 @@ Return per-context phenotype covariate matrices, taken from the } \examples{ data(qtlDatasetExample) -phenotypeCovariates(qtlDatasetExample, contexts = "brain") +phenotypeCovariates(qtlDatasetExample, context = "brain") } diff --git a/man/pip.Rd b/man/pip.Rd index 64258ed8..281a245f 100644 --- a/man/pip.Rd +++ b/man/pip.Rd @@ -15,18 +15,10 @@ pip(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, - returnList = FALSE + blockId = NULL ) -\S4method{pip}{QtlFineMappingResult}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - method = NULL, - returnList = FALSE -) +\S4method{pip}{QtlFineMappingResult}(x, studyName = NULL, context = NULL, trait = NULL, method = NULL) } \arguments{ \item{x}{A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}.} @@ -45,12 +37,8 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} - -\item{returnList}{Logical. If \code{TRUE}, return a per-entry list keyed by -identity tuple instead of a single flattened vector.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} } \value{ A named numeric vector of PIPs. diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index c7f57c4d..87b41580 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -56,8 +56,8 @@ are governed by \code{credibleSetParam}'s \code{perCsColumns} instead.} carry on the result untouched (returned as the \code{otherQuantities} element). Default \code{NULL}.} -\item{region}{Optional \code{"chr:start-end"} string naming the region the -fits cover; recorded on the result. Default \code{NULL}.} +\item{region}{Optional \code{GRanges}: the window the fits cover, recorded +on the result. Default \code{NULL}.} \item{priorEffTol}{Numeric (length 1). Effects whose prior variance \code{V} is at or below this tolerance are dropped as unconverged before diff --git a/man/pval.Rd b/man/pval.Rd index ed61f24d..0dc89c33 100644 --- a/man/pval.Rd +++ b/man/pval.Rd @@ -7,14 +7,7 @@ \usage{ pval(x, ...) -\S4method{pval}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{pval}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -29,12 +22,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of p-values, or \code{NULL} if not available. diff --git a/man/qcDiagnostics.Rd b/man/qcDiagnostics.Rd index d116c376..737d29c6 100644 --- a/man/qcDiagnostics.Rd +++ b/man/qcDiagnostics.Rd @@ -5,32 +5,30 @@ \alias{qcDiagnostics,SumStatsBase-method} \title{Get SLALOM / DENTIST Diagnostics} \usage{ -qcDiagnostics(x, entry = 1L, ...) +qcDiagnostics(x, ...) -\S4method{qcDiagnostics}{SumStatsBase}(x, entry = 1L) +\S4method{qcDiagnostics}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} -\item{entry}{Integer index (default 1) of the entry whose diagnostics table -to return. When \code{NULL}, returns a named list of every entry's -diagnostics keyed by entry index.} - \item{...}{Unused.} + +\item{studyName, context, trait}{Selectors pinning one study or entry; +\code{context} and \code{trait} are \code{QtlSumStats}-only.} } \value{ -A \code{data.frame} of per-variant diagnostics (columns include - \code{variant_id} plus the SLALOM / DENTIST output columns), \code{NULL} - when no diagnostics were preserved for that entry, or a named list of such - data.frames when \code{entry = NULL}. +A \code{DataFrame} of per-variant diagnostics (columns include + \code{variant_id} plus the SLALOM / DENTIST output columns), or + \code{NULL} when no diagnostics were preserved for the selection. } \description{ -Return the per-variant LD-mismatch diagnostics table (SLALOM or - DENTIST output) attached to a sumstats entry by - \code{\link{summaryStatsQc}} when \code{ldMismatchQcMethod} was not - \code{"none"}. - Convenience accessor over - \code{qcInfo(x)$entryAudit[[entry]]$ldMismatchDiagnostics}. +Return the per-variant LD-mismatch diagnostics (SLALOM or + DENTIST output) that \code{\link{summaryStatsQc}} attached to the + selected entry when \code{ldMismatchQcMethod} was not \code{"none"}. + The selectors pin one study (every row of a GWAS study, whose rows' + tables are stacked) or one \code{QtlSumStats} entry, as for + \code{\link{sumStats}}. } \examples{ data(qtlSumStatsExample) diff --git a/man/qcInfo.Rd b/man/qcInfo.Rd index bf9b23f7..9c2003cc 100644 --- a/man/qcInfo.Rd +++ b/man/qcInfo.Rd @@ -3,7 +3,7 @@ \name{qcInfo} \alias{qcInfo} \alias{qcInfo,SumStatsBase-method} -\title{Get QC Audit Record} +\title{Get the Per-Row QC Audit} \usage{ qcInfo(x, ...) @@ -15,15 +15,17 @@ qcInfo(x, ...) \item{...}{Unused.} } \value{ -A \code{list} (possibly empty). +A \code{DataFrame}, one row per tuple. } \description{ -Return the audit record of QC steps applied to this collection. - An empty \code{list()} (default on construction) means - \code{\link{summaryStatsQc}} has not yet been run. Pipelines that require - harmonized sumstats (\code{fineMappingPipeline}, - \code{twasWeightsPipeline}, and downstream consumers) reject inputs where - \code{length(qcInfo(x)) == 0L}. +What \code{\link{summaryStatsQc}} did to each row of a + summary-statistics collection: one row per tuple, its identity columns, + then the variant counts each QC step recorded (\code{variantsIn}, + \code{variantsOut}, and so on; a nested count is named by its path, as + in \code{contentFilters.nDropped}). A step that did not run on a row is + \code{NA} there. Only the identity columns are present before QC has run. + The options the QC ran with are \code{\link{qcOptions}}; the per-variant + LD-mismatch tables are \code{\link{qcDiagnostics}}. } \examples{ data(qtlSumStatsExample) diff --git a/man/qcOptions.Rd b/man/qcOptions.Rd new file mode 100644 index 00000000..581a8220 --- /dev/null +++ b/man/qcOptions.Rd @@ -0,0 +1,31 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{qcOptions} +\alias{qcOptions} +\alias{qcOptions,SumStatsBase-method} +\title{Get the QC Options} +\usage{ +qcOptions(x, ...) + +\S4method{qcOptions}{SumStatsBase}(x) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Unused.} +} +\value{ +A \code{list}, possibly empty. +} +\description{ +The record of the QC that ran over a summary-statistics + collection: the options \code{\link{summaryStatsQc}} was called with and + when. An empty \code{list()} (the default on construction) means QC has + not run; pipelines that need harmonized summary statistics + (\code{fineMappingPipeline}, \code{twasWeightsPipeline} and others) + refuse such inputs. What QC did to each row is \code{\link{qcInfo}}. +} +\examples{ +data(qtlSumStatsExample) +qcOptions(qtlSumStatsExample) +} diff --git a/man/qtlDatasetFilters.Rd b/man/qtlDatasetFilters.Rd deleted file mode 100644 index 3f0dc114..00000000 --- a/man/qtlDatasetFilters.Rd +++ /dev/null @@ -1,65 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{qtlDatasetFilters} -\alias{qtlDatasetFilters} -\alias{mafCutoff} -\alias{macCutoff} -\alias{xvarCutoff} -\alias{imissCutoff} -\alias{keepVariants} -\alias{keepIndel} -\alias{mafCutoff,QtlDataset-method} -\alias{macCutoff,QtlDataset-method} -\alias{xvarCutoff,QtlDataset-method} -\alias{imissCutoff,QtlDataset-method} -\alias{keepVariants,QtlDataset-method} -\alias{keepIndel,QtlDataset-method} -\title{QtlDataset Filter Settings} -\usage{ -mafCutoff(x, ...) - -macCutoff(x, ...) - -xvarCutoff(x, ...) - -imissCutoff(x, ...) - -keepVariants(x, ...) - -keepIndel(x, ...) - -\S4method{mafCutoff}{QtlDataset}(x) - -\S4method{macCutoff}{QtlDataset}(x) - -\S4method{xvarCutoff}{QtlDataset}(x) - -\S4method{imissCutoff}{QtlDataset}(x) - -\S4method{keepVariants}{QtlDataset}(x) - -\S4method{keepIndel}{QtlDataset}(x) -} -\arguments{ -\item{x}{A \code{QtlDataset}.} - -\item{...}{Additional arguments passed on to methods.} -} -\value{ -\code{mafCutoff()}, \code{macCutoff()}, - \code{xvarCutoff()} and \code{imissCutoff()} single numerics; - \code{keepVariants()} a character vector (empty when no restriction - was requested); \code{keepIndel()} a single logical. The sample set - is not among them: it lives in \code{colData(x)} and \code{sampleMap(x)}. -} -\description{ -The variant- and sample-filter settings a - \code{\link{QtlDataset}} was built with. They are recorded on the object - rather than reapplied per call, so reading them back is how a caller finds - out what a dataset already excludes. -} -\examples{ -data(qtlDatasetExample) -mafCutoff(qtlDatasetExample) -keepIndel(qtlDatasetExample) -} diff --git a/man/qtlDatasets.Rd b/man/qtlDatasets.Rd deleted file mode 100644 index 38ced58b..00000000 --- a/man/qtlDatasets.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/MultiStudyQtlDataset.R -\name{qtlDatasets} -\alias{qtlDatasets} -\alias{qtlDatasets,MultiStudyQtlDataset-method} -\title{Get the Embedded QtlDataset List} -\usage{ -qtlDatasets(x) - -\S4method{qtlDatasets}{MultiStudyQtlDataset}(x) -} -\arguments{ -\item{x}{A \code{MultiStudyQtlDataset} object.} -} -\value{ -A named list of \code{QtlDataset} objects. -} -\description{ -Return the named list of \code{QtlDataset} objects carried by a - \code{MultiStudyQtlDataset}. -} -\examples{ -data(multiStudyQtlDatasetExample) -qtlDatasets(multiStudyQtlDatasetExample) -} diff --git a/man/qtlEnrichment.Rd b/man/qtlEnrichment.Rd index 6adf6137..a9c9b1bd 100644 --- a/man/qtlEnrichment.Rd +++ b/man/qtlEnrichment.Rd @@ -14,7 +14,7 @@ qtlEnrichment( impN = 25, doubleShrinkage = FALSE, besselCorrection = TRUE, - numThreads = 1, + BPPARAM = SerialParam(), verbose = TRUE, alignNames = TRUE, seed = NULL @@ -48,8 +48,10 @@ enrichment estimate. Default \code{FALSE}.} \item{besselCorrection}{Logical. Apply Bessel's correction when estimating the sampling variance. Default \code{TRUE}.} -\item{numThreads}{Number of Simultaneous running CPU threads for multiple -imputation, default is 1.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the threads +the multiple imputation runs on when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +thread. Default \code{SerialParam()}.} \item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} @@ -119,11 +121,10 @@ names(susieFits) <- paste0("fit", seq_along(susieFits)) # Set other parameters impN <- 10 lambda <- 1 -numThreads <- 1 library(pecotmr) en <- qtlEnrichment( gwasPip, susieFits, lambda = lambda, impN = impN, - numThreads = numThreads) + BPPARAM = BiocParallel::SerialParam()) } \seealso{ diff --git a/man/qtlEnrichmentPipeline.Rd b/man/qtlEnrichmentPipeline.Rd index a9b0f378..15cc4ca5 100644 --- a/man/qtlEnrichmentPipeline.Rd +++ b/man/qtlEnrichmentPipeline.Rd @@ -8,7 +8,7 @@ qtlEnrichmentPipeline( gwasFineMappingResult, qtlFineMappingResult, qtlEnrichmentParam = QtlEnrichmentParam(), - numThreads = 1L, + BPPARAM = SerialParam(), seed = NULL, verbose = TRUE ) @@ -24,8 +24,9 @@ qtlEnrichmentPipeline( \code{besselCorrection}. A bare list is refused, since it cannot be checked.} -\item{numThreads}{Number of threads used by \code{qtlEnrichment}. Default -\code{1}.} +\item{BPPARAM}{A \code{BiocParallelParam} handed to +\code{\link{qtlEnrichment}}, whose multiple-imputation threads number +its workers. Default \code{SerialParam()}.} \item{seed}{Integer or \code{NULL}. Base random seed forwarded to \code{\link{qtlEnrichment}} for reproducible multiple imputation. @@ -34,11 +35,12 @@ checked.} \item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} } \value{ -A tibble with one row per (outcome trait, annotation unit) pair. +A tibble with one row per (outcome fit, annotation unit) pair. The identity columns are \code{gwasStudy}, \code{gwasContext}, - \code{gwasTrait}, \code{qtlStudy}, \code{qtlContext}; the axes a side does - not have are \code{NA} (\code{gwasContext} / \code{gwasTrait} for a GWAS - outcome, \code{qtlContext} for a GWAS annotation). Suitable as the + \code{gwasTrait}, \code{gwasMethod}, \code{qtlStudy}, \code{qtlContext}, + \code{qtlMethod}; the axes a side does not have are \code{NA} + (\code{gwasContext} / \code{gwasTrait} for a GWAS outcome, + \code{qtlContext} for a GWAS annotation). Suitable as the \code{enrichment} argument to \code{\link{colocPipeline}}, which joins on those columns. @@ -79,30 +81,37 @@ genome of outcome PIPs and the full collection of annotation fits at once. \itemize{ \item \code{gwasFineMappingResult}: the genome-wide outcome collection. 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. + vector. One PIP vector is built per outcome fit, across all its LD + blocks -- keyed by (\code{study}, \code{method}) for a GWAS collection + (one trait per study) and by (\code{study}, \code{context}, + \code{trait}, \code{method}) for a QTL one, since a variant's PIP + differs between molecular traits and between fine-mapping methods, and + pooling them would collide. \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. + (\code{study}, \code{context}, \code{method}) -- per (\code{study}, + \code{method}) for a GWAS collection, which has no context axis -- so + each method's fits make their own estimate rather than counting every + region once per method. } +Both sides' fits are read whole, so a row narrowed since its fit warns +(condition class \code{pecotmrFitCoverage}). } \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. + Every row of a GWAS outcome + collection must have an \code{ldReference} (it should be RSS-derived). + For each QTL row and GWAS row whose regions overlap, where both carry + one, the two must be the same LD reference; rows that never overlap may + sit on different references. 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. + its own surviving variants, and a partial overlap only warns. A row with + no reference on either side (an individual-level fit) skips the check. } \examples{ diff --git a/man/qtlSumStatsExample.Rd b/man/qtlSumStatsExample.Rd index d6042aa3..20411622 100644 --- a/man/qtlSumStatsExample.Rd +++ b/man/qtlSumStatsExample.Rd @@ -12,8 +12,8 @@ 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{ldReference} slot -references the same toy PLINK1 panel. +phenotype by per-variant linear regression. Its LD reference is the same +toy PLINK1 panel. } \examples{ data(qtlSumStatsExample) diff --git a/man/qtlSumStatsFromBetaMatrix.Rd b/man/qtlSumStatsFromBetaMatrix.Rd index 3a0bc2d3..76af4617 100644 --- a/man/qtlSumStatsFromBetaMatrix.Rd +++ b/man/qtlSumStatsFromBetaMatrix.Rd @@ -43,7 +43,7 @@ colnames(bhat)}, \code{trait = "mash"}.} \item{a1, a2}{Placeholder alleles. Defaults \code{"A"} / \code{"G"}.} -\item{role}{Tag stored in the \code{qcInfo} record. Default \code{"mash"}.} +\item{role}{Tag stored in the \code{qcOptions()}. Default \code{"mash"}.} } \value{ A \code{\link{QtlSumStats}} with one entry per condition (column). diff --git a/man/qtlSumStatsFromZMatrix.Rd b/man/qtlSumStatsFromZMatrix.Rd index b28915e7..c8760ab2 100644 --- a/man/qtlSumStatsFromZMatrix.Rd +++ b/man/qtlSumStatsFromZMatrix.Rd @@ -44,7 +44,7 @@ are traits rather than contexts.} \item{a1, a2}{Placeholder alleles. Defaults \code{"A"} / \code{"G"}.} -\item{role}{Tag stored in the \code{qcInfo} record. Default \code{"mash"}.} +\item{role}{Tag stored in the \code{qcOptions()}. Default \code{"mash"}.} } \value{ A \code{\link{QtlSumStats}} with one entry per condition (column). @@ -60,7 +60,7 @@ Assemble a per-condition \code{\link{QtlSumStats}} from a \code{\link{parseVariantId}} (with a synthetic-position fallback for ids that do not encode coordinates); \code{A1} / \code{A2} / \code{N} are placeholders because a Z-only input carries no alleles or sample sizes - (mash reads only Z). A pass-through \code{qcInfo} record is set so the + (mash reads only Z). Pass-through \code{qcOptions()} are set so the result clears the mash QC gate. } \examples{ diff --git a/man/raiss.Rd b/man/raiss.Rd index c0f2b7e2..e1634d2a 100644 --- a/man/raiss.Rd +++ b/man/raiss.Rd @@ -20,12 +20,16 @@ raiss( \arguments{ \item{refPanel}{A data frame containing 'chrom', 'pos', 'variant_id', 'A1', 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.} +panel, whose own variants are used. 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.} +'A1', 'A2', and 'z' values, or a summary-statistics \code{GRanges} -- +one entry as \code{\link{sumStats}} returns it, with its \code{SNP}, +\code{A1}, \code{A2} and \code{Z} columns. Here and in \code{refPanel} +a chromosome may be labelled in any style (\code{22}, \code{"22"}, +\code{"chr22"}); both are read in UCSC style (\code{"chr22"}), which +the result uses.} \item{ldMatrix}{A square LD matrix over \code{refPanel}'s variants, in its order, or an \code{LdMatrix} covering them. Provide either diff --git a/man/readAfreq.Rd b/man/readAfreq.Rd index 87fcb0dd..80b4c4ba 100644 --- a/man/readAfreq.Rd +++ b/man/readAfreq.Rd @@ -4,10 +4,10 @@ \alias{readAfreq} \title{Read a PLINK2 allele frequency file (.afreq or .afreq.zst)} \usage{ -readAfreq(prefix) +readAfreq(path) } \arguments{ -\item{prefix}{File prefix (without .afreq extension).} +\item{path}{File prefix (without .afreq extension).} } \value{ A data.frame with columns: chrom, id, A2 (REF), A1 (ALT), alt_freq, diff --git a/man/readAnnotations.Rd b/man/readAnnotations.Rd index 54d77ace..c3425a25 100644 --- a/man/readAnnotations.Rd +++ b/man/readAnnotations.Rd @@ -5,12 +5,12 @@ \alias{readAnnotations,character-method} \title{Read Annotations} \usage{ -readAnnotations(paths, snpRanges, annotationMeta = NULL, genome = "hg19", ...) +readAnnotations(path, snpRanges, annotationMeta = NULL, genome = "hg19", ...) -\S4method{readAnnotations}{character}(paths, snpRanges, annotationMeta = NULL, genome = "hg19") +\S4method{readAnnotations}{character}(path, snpRanges, annotationMeta = NULL, genome = "hg19") } \arguments{ -\item{paths}{Named character vector of file paths, or a named list of GRanges +\item{path}{Named character vector of file paths, or a named list of GRanges objects. Names become annotation names.} \item{snpRanges}{A \code{GRanges} object defining SNP positions.} diff --git a/man/readFineMappingResult.Rd b/man/readFineMappingResult.Rd index 644c15c4..5dcbb761 100644 --- a/man/readFineMappingResult.Rd +++ b/man/readFineMappingResult.Rd @@ -6,7 +6,7 @@ \usage{ readFineMappingResult( path, - region = NULL, + which = NULL, format = c("auto", "bed", "vcf"), studyName = NULL, context = NULL, @@ -20,12 +20,12 @@ readFineMappingResult( } \arguments{ \item{path}{Path to the published file. Bgzipped and tabix-indexed files -can be read by region.} +can be read in part, with \code{which}.} -\item{region}{Optional region to restrict the read to -- a -\code{"chr:start-end"} string, a \code{GRanges}, or a one-row -\code{data.frame} with chrom/start/end. Ignored with a warning when the -file is not tabix-indexed.} +\item{which}{Optional \code{GRanges}: read only the records that overlap +it, as \code{which} does for \code{rtracklayer::import()} and +\code{VariantAnnotation::ScanVcfParam()}. Ignored with a warning when +the file is not tabix-indexed.} \item{format}{\code{"auto"} (default) reads a \code{.vcf} / \code{.bcf} path as a VCF and anything else as a published table; \code{"bed"} / @@ -57,10 +57,10 @@ A \code{QtlFineMappingResult} or \code{GwasFineMappingResult}. } \description{ Rebuild a \code{QtlFineMappingResult} or - \code{GwasFineMappingResult} from a file \code{\link{exportToBed}} or - \code{\link{exportToVcf}} wrote -- or from any file in the same - vocabulary, which is what makes this the way into pecotmr for results - produced elsewhere. + \code{GwasFineMappingResult} from a file \code{\link{writeBed}} or + \code{\link{writeGwasVcf}} wrote -- or from any file in + the same vocabulary, which is what makes this the way into pecotmr for + results produced elsewhere. A merged table holding several \code{(study, context, trait, method)} tuples reads back as a multi-row collection, one row per tuple. Which @@ -91,7 +91,7 @@ Rebuild a \code{QtlFineMappingResult} or Every published quantity comes back identical, in either format. Three things are not identities: \itemize{ - \item \code{exportToBed()} publishes the \strong{filtered} top-loci + \item \code{writeBed()} publishes the \strong{filtered} top-loci table, so a default export holds the variants that passed \code{signalCutoff} / \code{minPurity} rather than every variant of the fit. Export with \code{signalCutoff = 0} for the whole table. @@ -109,13 +109,13 @@ Rebuild a \code{QtlFineMappingResult} or \examples{ data(qtlFineMappingExample) path <- file.path(tempdir(), "top_loci.bed") -exportToBed(qtlFineMappingExample, path) +writeBed(qtlFineMappingExample, path) # This fit predates the provenance columns, so its published table does # not say which genotype scale its posterior effects are on -- the reader # will not guess. readFineMappingResult(path, weightStandardized = TRUE) } \seealso{ -\code{\link{exportToBed}}, \code{\link{exportToVcf}}, +\code{\link{writeBed}}, \code{\link{writeGwasVcf}}, \code{\link{readTwasWeights}} } diff --git a/man/readGenotypes.Rd b/man/readGenotypes.Rd index 66670574..2753ec35 100644 --- a/man/readGenotypes.Rd +++ b/man/readGenotypes.Rd @@ -21,7 +21,7 @@ readGenotypes(path, format = NULL, ...) pvar = NULL, psam = NULL, ldMeta = NULL, - region = NULL, + block = NULL, genoMeta = NULL, chroms = NULL, format = NULL, @@ -79,12 +79,12 @@ triplet, when they do not share a stem.} plink2 triplet, when they do not share a stem.} \item{ldMeta}{Path to an LD-meta TSV (columns \code{chrom}, \code{start}, -\code{end}, \code{path}). Requires \code{region}: the row covering it is +\code{end}, \code{path}). Requires \code{block}: the row covering it is resolved and the file it names is read with the matching backend.} -\item{region}{Region to resolve out of \code{ldMeta}: a -\code{"chr:start-end"} string, or a one-row data.frame with -\code{chrom}, \code{start}, \code{end}.} +\item{block}{The \code{GRanges} window whose LD block to read out of +\code{ldMeta}. It chooses a file rather than filtering records: the +panel is the whole LD block that covers it.} \item{genoMeta}{One-file-per-chromosome specification: a path to a \code{#chr,path} meta file, or a named character vector (names = @@ -92,8 +92,9 @@ 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 -labels are compared canonically. Meaningful only with \code{genoMeta}.} +\code{genoMeta} shards whose chromosome is listed are read; a label may +be in any style (\code{"chr1"} or \code{"1"}). Meaningful only with +\code{genoMeta}.} } \value{ A \code{RangedSummarizedExperiment} of variants x samples. @@ -117,7 +118,7 @@ Read genotype data (VCF, plink1, plink2, GDS or BGEN) as a \code{plink2Prefix} for a triplet stem, \code{bed}/\code{bim}/\code{fam} or \code{pgen}/\code{pvar}/\code{psam} for explicit triplet paths, \code{genoMeta} for a one-file-per-chromosome panel (optionally narrowed - with \code{chroms}), or \code{ldMeta} plus \code{region} to resolve a + with \code{chroms}), or \code{ldMeta} plus \code{block} to resolve a block out of an LD-meta table. Exactly one source may be given. } \examples{ diff --git a/man/readSldscAnnot.Rd b/man/readSldscAnnot.Rd index 5478fc33..8aaf427f 100644 --- a/man/readSldscAnnot.Rd +++ b/man/readSldscAnnot.Rd @@ -4,10 +4,10 @@ \alias{readSldscAnnot} \title{Read target annotation files (.annot.gz) into one table} \usage{ -readSldscAnnot(targetAnnoDir, annotCols = NULL) +readSldscAnnot(path, annotCols = NULL) } \arguments{ -\item{targetAnnoDir}{Character. Directory of `.annot.gz` files.} +\item{path}{Character. Directory of `.annot.gz` files.} \item{annotCols}{Character or integer vector, default NULL. Annotation columns to keep. NULL keeps all non-standard columns (auto-detected).} diff --git a/man/readSldscFrq.Rd b/man/readSldscFrq.Rd index b368a226..ab5d0121 100644 --- a/man/readSldscFrq.Rd +++ b/man/readSldscFrq.Rd @@ -4,10 +4,10 @@ \alias{readSldscFrq} \title{Read PLINK allele-frequency files (.frq) into one table} \usage{ -readSldscFrq(frqfileDir, plinkName = "ADSP_chr") +readSldscFrq(path, plinkName = "ADSP_chr") } \arguments{ -\item{frqfileDir}{Character. Directory of `.frq` files.} +\item{path}{Character. Directory of `.frq` files.} \item{plinkName}{Character. Filename prefix (files at `.frq`). Falls back to all `*.frq` in the directory when diff --git a/man/readSldscTrait.Rd b/man/readSldscTrait.Rd index c4931e8e..9fb73391 100644 --- a/man/readSldscTrait.Rd +++ b/man/readSldscTrait.Rd @@ -4,10 +4,10 @@ \alias{readSldscTrait} \title{Read S-LDSC outputs from polyfun for one trait/run} \usage{ -readSldscTrait(prefix) +readSldscTrait(path) } \arguments{ -\item{prefix}{Character. Path prefix to the polyfun outputs for one +\item{path}{Character. Path prefix to the polyfun outputs for one trait/run. The function appends `.results`, `.log`, and `.part_delete` to this prefix. Example: `"/path/to/cwd/CAD_META.filtered.sumstats.gz"`.} } diff --git a/man/readTwasWeights.Rd b/man/readTwasWeights.Rd index 54f845e8..92b9da66 100644 --- a/man/readTwasWeights.Rd +++ b/man/readTwasWeights.Rd @@ -6,7 +6,7 @@ \usage{ readTwasWeights( path, - region = NULL, + which = NULL, format = c("auto", "bed", "vcf"), studyName = NULL, context = NULL, @@ -19,12 +19,12 @@ readTwasWeights( } \arguments{ \item{path}{Path to the published file. Bgzipped and tabix-indexed files -can be read by region.} +can be read in part, with \code{which}.} -\item{region}{Optional region to restrict the read to -- a -\code{"chr:start-end"} string, a \code{GRanges}, or a one-row -\code{data.frame} with chrom/start/end. Ignored with a warning when the -file is not tabix-indexed.} +\item{which}{Optional \code{GRanges}: read only the records that overlap +it, as \code{which} does for \code{rtracklayer::import()} and +\code{VariantAnnotation::ScanVcfParam()}. Ignored with a warning when +the file is not tabix-indexed.} \item{format}{\code{"auto"} (default) reads a \code{.vcf} / \code{.bcf} path as a VCF and anything else as a published table; \code{"bed"} / @@ -49,8 +49,8 @@ A \code{TwasWeights}. } \description{ Rebuild a \code{TwasWeights} from a file - \code{\link{exportToBed}} or \code{\link{exportToVcf}} wrote, or from any - file in the same vocabulary. + \code{\link{writeBed}} or \code{\link{writeGwasVcf}} + wrote, or from any file in the same vocabulary. A merged table reads back as a multi-row collection, one row per \code{(study, context, trait, method)} tuple. A fitted model whose @@ -77,9 +77,9 @@ Rebuild a \code{TwasWeights} from a file \examples{ data(twasWeightsExample) path <- file.path(tempdir(), "weights.bed") -exportToBed(twasWeightsExample, path) +writeBed(twasWeightsExample, path) readTwasWeights(path) } \seealso{ -\code{\link{exportToBed}}, \code{\link{readFineMappingResult}} +\code{\link{writeBed}}, \code{\link{readFineMappingResult}} } diff --git a/man/refVariantInfo.Rd b/man/refVariantInfo.Rd index ec559bb7..8ae34042 100644 --- a/man/refVariantInfo.Rd +++ b/man/refVariantInfo.Rd @@ -4,13 +4,13 @@ \alias{refVariantInfo} \title{Get variant information from any LD reference source} \usage{ -refVariantInfo(source, region = NULL) +refVariantInfo(source, which = NULL) } \arguments{ \item{source}{Genotype file path/prefix or LD metadata file path.} -\item{region}{Region of interest: "chr:start-end" string or data.frame with -chrom/start/end. If NULL, returns all variants.} +\item{which}{Optional \code{GRanges}: return only the variants that +overlap it. If NULL, returns all variants.} } \value{ A data.frame with columns: chrom, id, pos, A2, A1. May also include @@ -26,5 +26,6 @@ extracts variant info. \examples{ meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", package = "pecotmr") -refVariantInfo(meta, region = "chr22:10000000-19000000") +refVariantInfo(meta, + which = GenomicRanges::GRanges("chr22:10000000-19000000")) } diff --git a/man/regionToDf.Rd b/man/regionToDf.Rd deleted file mode 100644 index 466d0ae1..00000000 --- a/man/regionToDf.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{regionToDf} -\alias{regionToDf} -\title{Utility function to convert LD region_ids to `region of interest` dataframe} -\usage{ -regionToDf(ldRegionId, colnames = c("chrom", "start", "end")) -} -\arguments{ -\item{ldRegionId}{A string of region in the format of chrom_start_end.} - -\item{colnames}{Character vector of length 3 giving output column names for -chromosome, start and end. Default \code{c("chrom", "start", "end")}.} -} -\value{ -A tibble with one row per input region and columns named by - \code{colnames}: a normalized character chromosome plus integer start/end. -} -\description{ -The first field is treated as the chromosome and kept as a normalized string -(via \code{canonChrom}) so X/Y/MT survive; the remaining fields are genomic -positions and are returned as integers. -} -\examples{ -regionToDf(c("1_100_200", "2_300_400")) -} diff --git a/man/residualizedGenotypes.Rd b/man/residualizedGenotypes.Rd index 7e6e4a60..9d03d7c7 100644 --- a/man/residualizedGenotypes.Rd +++ b/man/residualizedGenotypes.Rd @@ -9,37 +9,16 @@ residualizedGenotypes(x, ...) \S4method{residualizedGenotypes}{QtlDataset}( x, - contexts, - traitId = NULL, - region = NULL, - cisWindow = NULL, - samples = NULL, + context, residualizationParam = ResidualizationParam() ) } \arguments{ \item{x}{A \code{QtlDataset} object.} -\item{...}{Selection arguments: \code{traitId}, \code{region}, -\code{cisWindow}, \code{phenotypeCovariatesToRemove}, -\code{genotypeCovariatesToRemove}, and \code{covariateNaAction} -(\code{"impute"}, the default, mean-imputes missing covariate cells; -\code{"drop"} removes samples with any missing covariate).} +\item{...}{Passed on to methods.} -\item{contexts}{Character vector. Context(s) whose data to extract.} - -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier -to select; \code{NULL} matches all traits in the dataset.} - -\item{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.} - -\item{cisWindow}{Integer or \code{NULL}. Half-width (bp) of the cis window -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{context}{Character vector. Context(s) whose data to extract.} \item{residualizationParam}{What the data is residualized on, built with \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and @@ -54,11 +33,11 @@ A numeric matrix (samples x variants). } \description{ Residualize the genotype matrix against the per-context - phenotype covariates and the genotype covariates, optionally subsetting - variants to those falling within a trait's cis-window or an explicit - region. + phenotype covariates and the genotype covariates, over the whole + dataset: narrow it first, with \code{x[i, j, ]}, to residualize part + of it. } \examples{ data(qtlDatasetExample) -residualizedGenotypes(qtlDatasetExample, contexts = "brain") +residualizedGenotypes(qtlDatasetExample, context = "brain") } diff --git a/man/residualizedPhenotypes.Rd b/man/residualizedPhenotypes.Rd index 28881f8b..01924223 100644 --- a/man/residualizedPhenotypes.Rd +++ b/man/residualizedPhenotypes.Rd @@ -9,48 +9,21 @@ residualizedPhenotypes(x, ...) \S4method{residualizedPhenotypes}{QtlDataset}( x, - contexts, - traitId = NULL, - region = NULL, - naAction = c("keep", "drop", "impute"), - outlierAction = c("keep", "drop"), - outlierPvalThreshold = 0.001, - outlierArgs = CovMcdOptions(), + context, + trait = NULL, residualizationParam = ResidualizationParam() ) } \arguments{ \item{x}{A \code{QtlDataset} object.} -\item{...}{Selection arguments: \code{contexts} (required), \code{traitId}, -\code{region}, \code{phenotypeCovariatesToRemove}, -\code{genotypeCovariatesToRemove}, and \code{covariateNaAction} -(\code{"impute"}, the default, mean-imputes missing covariate cells; -\code{"drop"} removes samples with any missing covariate).} +\item{...}{Passed on to methods.} -\item{contexts}{Character vector. Context(s) whose data to extract.} +\item{context}{Character vector. Context(s) whose data to extract.} -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier +\item{trait}{Character or \code{NULL}. Molecular trait / feature identifier to select; \code{NULL} matches all traits in the dataset.} -\item{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.} - -\item{naAction}{Character. How to handle missing phenotype values: one of -\code{"keep"}, \code{"drop"}, or \code{"impute"}.} - -\item{outlierAction}{Character. How to handle phenotype outliers: one of -\code{"keep"} or \code{"drop"}.} - -\item{outlierPvalThreshold}{Numeric. Two-sided p-value threshold for flagging -phenotype outliers. Default \code{1e-3}.} - -\item{outlierArgs}{Extra arguments for \code{robustbase::covMcd()}, the -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{residualizationParam}{What the data is residualized on, built with \code{\link{ResidualizationParam}}: \code{phenotypeCovariates} and \code{genotypeCovariates} choose the covariate sets, @@ -65,9 +38,11 @@ A named list of numeric matrices keyed by context. \description{ Residualize the per-context phenotype matrices against the per-context phenotype covariates and the genotype covariates, for one or - more requested contexts. + more requested contexts. Missing values and outliers are left as they + are: they are a run's phenotype QC (\code{\link{PhenotypeFilterParam}}), + applied by the pipelines. } \examples{ data(qtlDatasetExample) -residualizedPhenotypes(qtlDatasetExample, contexts = "brain") +residualizedPhenotypes(qtlDatasetExample, context = "brain") } diff --git a/man/resolveWeights.Rd b/man/resolveWeights.Rd index 2fd92ce8..623ee00f 100644 --- a/man/resolveWeights.Rd +++ b/man/resolveWeights.Rd @@ -14,7 +14,7 @@ resolveWeights(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) \S4method{resolveWeights}{TwasWeights}( @@ -35,9 +35,8 @@ resolveWeights(x, ...) 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 fine-mapping result, whose rows also carry a -region; \code{NULL} (default) leaves it unconstrained.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block; \code{NULL} (default) leaves it unconstrained.} } \value{ A \code{list} with \code{variantIds} (character) and \code{weights} diff --git a/man/retainedMass.Rd b/man/retainedMass.Rd index 23cbdec1..9f35efef 100644 --- a/man/retainedMass.Rd +++ b/man/retainedMass.Rd @@ -15,7 +15,7 @@ retainedMass(x, ...) \item{...}{Additional arguments passed to methods.} } \value{ -A \code{data.frame}, one row per (element, effect), with the +A \code{DataFrame}, one row per (element, effect), with the element's identity columns, the effect index, and its retained mass. } \description{ diff --git a/man/ridgeRssWeights.Rd b/man/ridgeRssWeights.Rd new file mode 100644 index 00000000..daabde91 --- /dev/null +++ b/man/ridgeRssWeights.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{ridgeRssWeights} +\alias{ridgeRssWeights} +\title{Compute Ridge Weights from Summary Statistics} +\usage{ +ridgeRssWeights( + stat, + ldReference, + s = c(0.2, 0.5, 0.9, 1), + selection = c("ldQuadratic", "minFbeta"), + fitRetention = c("none", "slim", "full"), + methodArgs = PenalizedRssOptions() +) +} +\arguments{ +\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{s}{Numeric vector of LD shrinkage parameters. Default: \code{c(0.2, +0.5, 0.9, 1.0)}.} + +\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or +\code{"minFbeta"}.} + +\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. Unless + \code{fitRetention = "none"}, the search is attached as attribute + \code{"fit"}. +} +\description{ +Fits ridge regression on the RSS objective, \code{\link{enetRssWeights}} +at \code{alpha = 0}: the penalty is \eqn{\lambda \beta^T \beta}, and the +default lambda path runs from 0.1 to 100. Searches over a shrinkage grid +\code{s} as well, whose own ridge term \eqn{s \beta^T \beta} adds to it; +model selection uses LD-quadratic pseudovalidation by default. +} +\examples{ +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:30] +y <- eqtlRegionExample$yRes +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)), + variantNames = colnames(X) +) +ridgeRssWeights(stat, LdMatrix(cor(X))) +} diff --git a/man/ridgeWeights.Rd b/man/ridgeWeights.Rd new file mode 100644 index 00000000..fb224292 --- /dev/null +++ b/man/ridgeWeights.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/regularizedRegressionWrappers.R +\name{ridgeWeights} +\alias{ridgeWeights} +\title{Compute TWAS weights via ridge regression (glmnet, alpha = 0)} +\usage{ +ridgeWeights(X, y, methodArgs = GlmnetOptions()) +} +\arguments{ +\item{X}{Numeric genotype / design matrix (samples x variants).} + +\item{y}{Numeric response (phenotype) vector of length \code{nrow(X)}.} + +\item{methodArgs}{Additional arguments forwarded to +\code{glmnet::cv.glmnet}, built with \code{\link{GlmnetOptions}}. A bare +list is refused, since it cannot be checked against the engine's formals.} +} +\value{ +Numeric vector of length \code{ncol(X)} of per-variant weights. +} +\description{ +Convenience wrapper for \code{\link{glmnetWeights}} with \code{alpha = 0}. +} +\examples{ +data(eqtlRegionExample) +X <- eqtlRegionExample$X[, 1:30] +y <- eqtlRegionExample$yRes +ridgeWeights(X, y) +} diff --git a/man/sampleSize.Rd b/man/sampleSize.Rd new file mode 100644 index 00000000..62ae7fdd --- /dev/null +++ b/man/sampleSize.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{sampleSize} +\alias{sampleSize} +\alias{sampleSize,SumStatsBase-method} +\title{Get Per-Variant Sample Sizes} +\usage{ +sampleSize(x, ...) + +\S4method{sampleSize}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Class-specific selection arguments.} + +\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.} + +\item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to +this trait; \code{NULL} matches all traits.} +} +\value{ +Numeric vector of per-variant sample sizes, or \code{NULL} when the + entry carries none. +} +\description{ +Extract the per-variant sample-size vector (the \code{N} + column) of a \code{GwasSumStats} or \code{QtlSumStats} entry, selected + by its identity tuple. Part of the summary-statistic column set alongside + \code{\link{z}}, \code{\link{se}} and \code{\link{pval}}; replace it + with \code{\link[=variantColumnReplace]{sampleSize<-}}. +} +\examples{ +data(qtlSumStatsExample) +head(sampleSize(qtlSumStatsExample)) +} diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index 86734f30..bbc7966b 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -33,7 +33,9 @@ standardized genotypes, never formed as a matrix.} \item{gamma}{SCAD concavity parameter. Default 3.7.} -\item{alpha}{Elastic-net mixing (1 = pure L1). Default 1.} +\item{alpha}{Elastic-net mixing in \code{(0, 1]}: the SCAD share of +the penalty, the rest a ridge term, as \code{\link{penalizedRss}} +mixes them. Default 1, no ridge term.} \item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or \code{"minFbeta"}.} diff --git a/man/scaleResiduals.Rd b/man/scaleResiduals.Rd deleted file mode 100644 index 34028a0b..00000000 --- a/man/scaleResiduals.Rd +++ /dev/null @@ -1,25 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/QtlDataset.R -\name{scaleResiduals} -\alias{scaleResiduals} -\alias{scaleResiduals,QtlDataset-method} -\title{Get scaleResiduals Flag} -\usage{ -scaleResiduals(x) - -\S4method{scaleResiduals}{QtlDataset}(x) -} -\arguments{ -\item{x}{A \code{QtlDataset} object.} -} -\value{ -Logical (length 1). -} -\description{ -Whether residualization accessors scale residuals to unit - variance. -} -\examples{ -data(qtlDatasetExample) -scaleResiduals(qtlDatasetExample) -} diff --git a/man/screenCtwasRegions.Rd b/man/screenCtwasRegions.Rd index d1c2f29a..39c86e03 100644 --- a/man/screenCtwasRegions.Rd +++ b/man/screenCtwasRegions.Rd @@ -4,12 +4,19 @@ \alias{screenCtwasRegions} \title{Screen cTWAS regions} \usage{ -screenCtwasRegions(estResult, numThreads = 1L, methodArgs = CtwasOptions()) +screenCtwasRegions( + estResult, + BPPARAM = SerialParam(), + methodArgs = CtwasOptions() +) } \arguments{ \item{estResult}{A list returned by \code{\link{estCtwasGroupPriors}}.} -\item{numThreads}{Number of cores.} +\item{BPPARAM}{A \code{BiocParallelParam} whose workers number the cores +ctwas's own \code{ncore} parallelism uses when they run on this machine +(\code{SerialParam}, \code{MulticoreParam}); any other backend gives one +core. Default \code{SerialParam()}.} \item{methodArgs}{Additional arguments forwarded to ctwas, built with \code{\link{CtwasOptions}}. Names are checked against what diff --git a/man/sdpr.Rd b/man/sdpr.Rd index 89963fa5..ba60f01e 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -19,7 +19,6 @@ sdpr( iter = 1000, burn = 200, thin = 5, - numThreads = 1, optLlk = 1, verbose = TRUE, seed = NULL @@ -57,8 +56,6 @@ length equal to `bhat`.} \item{thin}{Thinning interval for MCMC. Default is 5.} -\item{numThreads}{Number of threads to use. Default is 1.} - \item{optLlk}{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.} diff --git a/man/se.Rd b/man/se.Rd index adec8fac..e47147c5 100644 --- a/man/se.Rd +++ b/man/se.Rd @@ -7,14 +7,7 @@ \usage{ se(x, ...) -\S4method{se}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{se}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -29,12 +22,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of standard errors, or \code{NULL} if not available. diff --git a/man/show-methods.Rd b/man/show-methods.Rd index adc2515f..850331b6 100644 --- a/man/show-methods.Rd +++ b/man/show-methods.Rd @@ -1,16 +1,17 @@ % 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/LdEigen.R, -% R/LdScore.R, R/MashPrior.R, R/qtlSumStats.R, R/QtlDataset.R, -% R/MultiStudyQtlDataset.R, R/QtlFineMappingResult.R, R/gwasSumStats.R, -% R/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R +% R/CtwasResultEntry.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/fineMappingRow.R, R/twasWeights.R, R/twasWeightsRow.R \name{show-methods} \alias{show-methods} \alias{show,GenotypeHandle-method} \alias{show,AnnotationMatrix-method} \alias{show,ColocResult-method} \alias{show,ColocBoostResult-method} +\alias{show,CtwasResultEntry-method} \alias{show,CtwasResult-method} \alias{show,GwasFineMappingResult-method} \alias{show,H2Estimate-method} @@ -35,6 +36,8 @@ \S4method{show}{ColocBoostResult}(object) +\S4method{show}{CtwasResultEntry}(object) + \S4method{show}{CtwasResult}(object) \S4method{show}{GwasFineMappingResult}(object) diff --git a/man/sldscResults.Rd b/man/sldscResults.Rd index f4907f82..650fa495 100644 --- a/man/sldscResults.Rd +++ b/man/sldscResults.Rd @@ -7,29 +7,26 @@ \usage{ sldscResults(x, trait = NULL, ...) -\S4method{sldscResults}{SldscData}(x, trait = NULL, mode = c("single", "joint"), idx = NULL) +\S4method{sldscResults}{SldscData}(x, trait = NULL) } \arguments{ \item{x}{An \code{\link{SldscData}} object.} -\item{trait}{Character trait name, or \code{NULL} (default) to return the -named list of per-trait \code{single}/\code{joint} runs for all traits.} +\item{trait}{Character trait name(s), or \code{NULL} (default) for every +trait. A name the object does not hold is an error.} -\item{...}{Further arguments: \code{mode} (\code{"single"}/\code{"joint"}) -and \code{idx} (which single run).} - -\item{mode}{Character. Trait-run selection mode.} - -\item{idx}{Integer. Index of the trait run to select.} +\item{...}{Unused.} } \value{ -The named list of per-trait runs when \code{trait} is \code{NULL}; - otherwise a single run list, the list of single runs, or \code{NULL}. +A named list keyed by trait, each element a list with + \code{single} (a list of runs) and \code{joint} (one run, or + \code{NULL} when the trait has none). } \description{ Return the stratified LD-score regression runs held by an - \code{\link{SldscData}}: every trait's runs when \code{trait} is - \code{NULL}, otherwise the selected run(s) for that one trait. + \code{\link{SldscData}}, keyed by trait. Each trait's entry holds its + \code{single} runs (one per annotation) and its \code{joint} run, read + with \code{[[}: \code{sldscResults(x, "T")[["T"]]$joint}. } \examples{ mkRun <- function(cats) { @@ -55,5 +52,5 @@ mkTrait <- function() { } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) sd <- SldscData(annotData = annot, frqData = frq, traits = traits) -sldscResults(sd, "traitX") +sldscResults(sd, "traitX")[["traitX"]]$joint$categories } diff --git a/man/snpsPerBlock.Rd b/man/snpsPerBlock.Rd index 76d95d09..dd4a8255 100644 --- a/man/snpsPerBlock.Rd +++ b/man/snpsPerBlock.Rd @@ -9,7 +9,8 @@ snpsPerBlock(snpInfo, ldBlocks) \arguments{ \item{snpInfo}{A data.frame with columns CHR, BP.} -\item{ldBlocks}{A \code{GRanges} of LD block intervals.} +\item{ldBlocks}{The LD block intervals: a \code{GRanges}, or the path +of a BED file, read as BED with a 0-based start.} } \value{ A list of integer vectors, one per block. diff --git a/man/subsetChr.Rd b/man/subsetChr.Rd deleted file mode 100644 index 66742433..00000000 --- a/man/subsetChr.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/AllClasses.R -\name{subsetChr} -\alias{subsetChr} -\alias{subsetChr,SumStatsBase-method} -\title{Subset by Chromosome} -\usage{ -subsetChr(x, chr) - -\S4method{subsetChr}{SumStatsBase}(x, chr) -} -\arguments{ -\item{x}{A \code{GwasSumStats} object.} - -\item{chr}{Character, chromosome name (e.g., "1", "chr1").} -} -\value{ -A \code{GwasSumStats} object. -} -\description{ -Extract a chromosome-specific subset of a GwasSumStats object. -} -\examples{ -data(gwasSumStatsS4Example) -subsetChr(gwasSumStatsS4Example, "chr22") -} diff --git a/man/subsetRegion.Rd b/man/subsetRegion.Rd deleted file mode 100644 index 1fccb5fe..00000000 --- a/man/subsetRegion.Rd +++ /dev/null @@ -1,53 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/RangedTupleList.R -\name{subsetRegion} -\alias{subsetRegion} -\alias{subsetRegion,RangedTupleList-method} -\title{Restrict a Collection to a Region} -\usage{ -subsetRegion(x, region, ...) - -\S4method{subsetRegion}{RangedTupleList}(x, region) -} -\arguments{ -\item{x}{A \code{RangedTupleList} collection.} - -\item{region}{A \code{GRanges}, a \code{"chr:start-end"} string, or a -one-row \code{data.frame} with \code{chrom} / \code{start} / \code{end}.} - -\item{...}{Additional arguments passed to methods. Fine-mapping collections -accept \code{adjust} to renormalize PIPs over the retained variants.} -} -\value{ -An object of the same class as \code{x}, with the collection-level - slots carried over and \code{mcols} narrowed to the surviving elements. -} -\description{ -Narrow a \code{RangedTupleList} collection to an analysis - window: elements that do not overlap it are dropped, and the survivors are - trimmed to the overlapping variants. Elements that trim to zero variants - are dropped too. -} -\details{ -This is deliberately a new verb rather than a redefinition of a - Bioconductor generic, because three genuinely different operations are in - play and all three are useful: - \describe{ - \item{\code{subsetByOverlaps(x, win)}}{selects elements, keeps them - whole.} - \item{\code{restrict(x, start, end)}}{trims elements, keeps empty ones.} - \item{\code{subsetRegion(x, win)}}{selects AND trims AND drops empties.} - } - \code{subsetChr()} is the whole-seqname special case of this verb. -} -\examples{ -data(qtlSumStatsMulticontextExample) -mc <- qtlSumStatsMulticontextExample -sum(lengths(mc)) -# Every element is narrowed to the window; the collection keeps its shape, -# so an element with nothing left stays as an empty one rather than a -# dropped row. -sub <- subsetRegion(mc, "chr22:14560203-15000000") -sum(lengths(sub)) -nrow(sub) -} diff --git a/man/sumStats-GwasSumStats-method.Rd b/man/sumStats-GwasSumStats-method.Rd index b0f47423..97364908 100644 --- a/man/sumStats-GwasSumStats-method.Rd +++ b/man/sumStats-GwasSumStats-method.Rd @@ -7,7 +7,6 @@ \S4method{sumStats}{GwasSumStats}( x, studyName = NULL, - ranges = NULL, context = NULL, trait = NULL, annotateSignificance = NULL @@ -19,9 +18,6 @@ \item{studyName}{Character (length 1) study identifier. Optional when the collection has a single row.} -\item{ranges}{Optional \code{GRanges} restricting the returned variants to -those it overlaps. \code{NULL} (default) returns the study's full set.} - \item{context, trait, annotateSignificance}{QTL-only selectors, named here so that supplying one is an error rather than a silently ignored request. A GWAS has no context or trait axis and carries no significance annotation; diff --git a/man/sumStats.Rd b/man/sumStats.Rd index d4db4bd9..959b556c 100644 --- a/man/sumStats.Rd +++ b/man/sumStats.Rd @@ -14,8 +14,7 @@ sumStats(x, ...) studyName = NULL, context = NULL, trait = NULL, - annotateSignificance = NULL, - ranges = NULL + annotateSignificance = NULL ) \S4method{sumStats}{MultiStudyQtlDataset}(x) @@ -40,16 +39,8 @@ this trait; \code{NULL} matches all traits.} \code{"bonferroni_filtered"} / \code{"qvalue"}). When set on a QtlSumStats enriched by \code{\link{qtlAssociationPostprocess}}, a logical \code{significant} mcol for that method is added to the returned entry (the -significance is derived on the fly, not stored). Flat export flattens this -full entry GRanges (all mcols) directly; note -\code{\link{as.data.frame}} is a fixed GWAS-schema view and does not -carry the association columns.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). A selected tuple can -own several elements -- one per chromosome, since a multi-seqname entry is -split at construction -- and they are stitched back into a single -\code{GRanges}. Pass \code{ranges} to pull only the variants overlapping a -region instead of the whole span; \code{NULL} returns everything.} +significance is derived on the fly, not stored). Take a table of the +whole entry, every mcol included, with \code{as.data.frame()}.} } \value{ A \code{GRanges}, a \code{QtlSumStats}, or \code{NULL}. diff --git a/man/sumStatsDataFrame.Rd b/man/sumStatsDataFrame.Rd deleted file mode 100644 index 29fca09e..00000000 --- a/man/sumStatsDataFrame.Rd +++ /dev/null @@ -1,74 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% 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} -\title{Coerce Summary Statistics to a Data Frame} -\usage{ -\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}{GwasSumStats}( - x, - row.names = NULL, - optional = FALSE, - studyName = NULL, - require = character(0), - derive = c("none", "zFromBetaSe"), - keepChrPrefix = TRUE, - ... -) -} -\arguments{ -\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} - -\item{row.names, optional}{Accepted for compatibility with -\code{as.data.frame} and ignored.} - -\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.} - -\item{derive}{Whether to derive missing standard columns from the available -ones; \code{"zFromBetaSe"} recovers \code{z} from \code{beta}/\code{se}.} - -\item{keepChrPrefix}{Logical. If \code{TRUE}, keep the \code{chr} prefix on -chromosome names; otherwise strip it.} - -\item{...}{Unused.} -} -\value{ -A \code{data.frame}. -} -\description{ -Coerce one tuple of a \code{GwasSumStats} or - \code{QtlSumStats} collection to a per-variant \code{data.frame} in the - standardized layout \code{variant_id, chrom, pos, A1, A2, z, beta, se, N, - maf} (optional columns omitted when absent on the entry). This is the - table view of \code{\link{sumStats}}, which returns the same selection as - a \code{GRanges}; coercion rather than a return-type argument is the - Bioconductor idiom for choosing a representation. -} -\examples{ -data(qtlSumStatsExample) -head(as.data.frame(qtlSumStatsExample)) -} diff --git a/man/summaryStatsQc.Rd b/man/summaryStatsQc.Rd index d291b52b..41b2a050 100644 --- a/man/summaryStatsQc.Rd +++ b/man/summaryStatsQc.Rd @@ -49,8 +49,7 @@ disables it).} \item{keepVariants}{Optional character vector of variant IDs (SNP column) to retain prior to harmonization.} -\item{skipRegion}{Optional character vector of \code{"chr:start-end"} -strings, or a \code{GRanges}, of regions to drop.} +\item{skipRegion}{Optional \code{GRanges} of regions to drop.} \item{signalScreenParam}{Whether to skip an entry before fitting it, built with @@ -84,8 +83,9 @@ counts and an \code{N} column are present the counts win: \code{N} is overridden and the override is logged. Inputs with no counts (quantitative traits) are unchanged. The escape hatch \code{effectiveN = FALSE} restores the raw \code{N} column (or, when there is no \code{N}, the raw total -\code{nCase + nControl}) with no override. \code{qcInfo$options$effectiveN} -records the setting and each entry's \code{nSource} is one of +\code{nCase + nControl}) with no override. +\code{qcOptions(x)$options$effectiveN} records the setting and each +row's \code{nSource} (a \code{\link{qcInfo}} column) is one of \code{"effective"}, \code{"column"}, \code{"total"}, or \code{NA}.} \item{impute}{Logical (length 1). Run RAISS imputation against the @@ -99,7 +99,10 @@ records how many variants were imputed. Default \code{FALSE}.} RAISS imputation scopes its reference panel to the analysis-region window (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. + base pairs on each side to retain LD context for edge variants, though + never into the stretch of another row of the same study, nor past a + block range that was given: a study split into LD blocks imputes each + block once, in its own row. \code{mafCutoff}, \code{macCutoff} and \code{imissCutoff} bound which panel variants RAISS will attempt to impute. Without them every rare @@ -133,8 +136,8 @@ filter or screen. Distinct from \code{sumstatsFilterParam}, which applies quality thresholds to rows that are already well formed.} } \value{ -A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries - and \code{qcInfo} populated. +A new \code{QtlSumStats} / \code{GwasSumStats} with cleaned entries, + \code{qcOptions} filled and each row's QC audit attached. } \description{ Applies a single QC pass to a \code{QtlSumStats} or \code{GwasSumStats} @@ -150,10 +153,12 @@ and optional RAISS imputation. No Bioconductor genome / dbSNP packages required. } \details{ -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, -etc.). Fine-mapping and TWAS-weights pipelines reject SumStats inputs where -\code{length(qcInfo(x)) == 0L}. +The returned collection records the options QC ran with in its +\code{qcOptions} slot, and what QC did to each row (variant counts, drop +counts at each step, which filters fired, etc.) in its \code{qcAudit} +column, read as a table with \code{\link{qcInfo}}. Fine-mapping and +TWAS-weights pipelines reject SumStats inputs where +\code{length(qcOptions(x)) == 0L}. Column-availability error contract: a non-zero \code{infoCutoff} requires every entry to carry an \code{INFO} column, and a non-zero \code{nCutoff} @@ -168,8 +173,8 @@ filtered against the reference panel (see below). \code{\link{twasWeightsPipeline}} measure them on the RSS path, so one number means the same thing wherever it is set. MAC is converted to a MAF equivalent and the stricter of the two applies, matching - \code{\link{QtlDataset}}. Defaults (\code{0}, \code{0}, \code{1}) filter - nothing. + \code{\link{GenotypeFilterParam}}. Defaults (\code{0}, \code{0}, + \code{1}) filter nothing. The panel is filtered once, before any entry is harmonized, so a variant the panel cannot support is absent from the LD used by kriging, diff --git a/man/susieAlpha.Rd b/man/susieAlpha.Rd index 42d89ce2..83f79f3a 100644 --- a/man/susieAlpha.Rd +++ b/man/susieAlpha.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/CtwasResult.R, -% R/CtwasResultEntry.R +% Please edit documentation in R/AllGenerics.R, R/CtwasResultEntry.R, +% R/CtwasResult.R \name{susieAlpha} \alias{susieAlpha} -\alias{susieAlpha,CtwasResult-method} \alias{susieAlpha,CtwasResultEntry-method} +\alias{susieAlpha,CtwasResult-method} \title{Get cTWAS Per-effect Susie Alpha Table} \usage{ susieAlpha(x, ...) -\S4method{susieAlpha}{CtwasResult}(x) - \S4method{susieAlpha}{CtwasResultEntry}(x) + +\S4method{susieAlpha}{CtwasResult}(x) } \arguments{ \item{x}{A \code{CtwasResultEntry} or \code{CtwasResult}.} @@ -19,8 +19,11 @@ susieAlpha(x, ...) \item{...}{Class-specific selection arguments.} } \value{ -A \code{data.frame} of per-effect alphas (or \code{NULL} when - absent). +On a \code{CtwasResultEntry}, the stored alphas: a + \code{GRanges} when the pipeline placed its rows, the table as given + otherwise, or \code{NULL} when absent. On a \code{CtwasResult}, one + \code{GRanges} of every row's alphas with the run identity in + \code{mcols()} (empty when no row has any). } \description{ Return the full per-effect susie alpha table diff --git a/man/susieFit.Rd b/man/susieFit.Rd index 97736566..e32e80c2 100644 --- a/man/susieFit.Rd +++ b/man/susieFit.Rd @@ -15,7 +15,7 @@ susieFit(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) \S4method{susieFit}{FineMappingRow}(x) @@ -38,9 +38,8 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} } \value{ A list (the SuSiE fit object). diff --git a/man/susieResult.Rd b/man/susieResult.Rd index 7959846f..75880610 100644 --- a/man/susieResult.Rd +++ b/man/susieResult.Rd @@ -17,7 +17,9 @@ The trimmed fit (a list with \code{pip}, \code{sets}, etc.) or NULL. \description{ 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. +fine-mapping entry is attached. As \code{\link{susieFit}} does, it warns +(condition class \code{pecotmrFitCoverage}) when the entry holds fewer +variants than its fit was made with. } \examples{ data(qtlFineMappingExample) diff --git a/man/topLoci.Rd b/man/topLoci.Rd index 0673afb0..014ae501 100644 --- a/man/topLoci.Rd +++ b/man/topLoci.Rd @@ -14,9 +14,8 @@ topLoci(x, signalCutoff = 0.025, ...) context = NULL, trait = NULL, method = NULL, - region = NULL, - minPurity = NULL, - raw = FALSE + blockId = NULL, + minPurity = NULL ) } \arguments{ @@ -40,17 +39,11 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} \item{minPurity}{Numeric or \code{NULL}. Minimum credible-set purity to retain; \code{NULL} applies no purity filter.} - -\item{raw}{Logical (length 1). \code{FALSE} (default) returns the posterior -view described above. \code{TRUE} hands back the stored canonical table -verbatim -- a \code{data.frame}, not a \code{GRanges} -- so neither the -projection nor \code{signalCutoff} applies.} } \value{ A \code{GRanges}, one range per retained variant, carrying the @@ -59,7 +52,7 @@ A \code{GRanges}, one range per retained variant, carrying the with \code{as.data.frame()} (which adds the standard \code{seqnames}/\code{start}/... columns) or \code{as.data.frame(S4Vectors::mcols(.))} for the per-variant columns - alone. \code{raw = TRUE} returns the stored \code{data.frame} instead. + alone. } \description{ Extract the per-variant posterior fine-mapping payload as either diff --git a/man/traitPosition.Rd b/man/traitPosition.Rd index 933a0b83..61b9bb3d 100644 --- a/man/traitPosition.Rd +++ b/man/traitPosition.Rd @@ -13,9 +13,9 @@ traitPosition(x, ...) \S4method{traitPosition}{FineMappingResultBase}(x) -\S4method{traitPosition}{QtlSumStats}(x, traitId = NULL) +\S4method{traitPosition}{QtlSumStats}(x, trait = NULL) -\S4method{traitPosition}{QtlDataset}(x, traitId = NULL) +\S4method{traitPosition}{QtlDataset}(x, trait = NULL) \S4method{traitPosition}{TwasWeights}(x) } @@ -24,12 +24,15 @@ traitPosition(x, ...) \item{...}{Reserved for future use.} -\item{traitId}{Character or \code{NULL}. Molecular trait / feature identifier +\item{trait}{Character or \code{NULL}. Molecular trait / feature identifier to select; \code{NULL} matches all traits in the dataset.} } \value{ -A \code{GRanges} with one range per row of \code{x}, or an empty - \code{GRanges} when the collection carries no trait-position provenance. +A \code{GRanges}: one range per row of a collection, or an empty + \code{GRanges} when the collection carries no trait-position provenance + (or, for a \code{QtlSumStats} with \code{trait} given, none of those + traits). For a \code{QtlDataset}, one range per requested trait, named + by trait; a trait in no context is an error. } \description{ Return the molecular feature's OWN genomic coordinates (the gene diff --git a/man/twasEngineOptions.Rd b/man/twasEngineOptions.Rd index f0e88157..ae8a85d8 100644 --- a/man/twasEngineOptions.Rd +++ b/man/twasEngineOptions.Rd @@ -61,8 +61,10 @@ Options forwarded to the engine behind a TWAS weight method, A method's individual-level and summary-statistic paths often run DIFFERENT engines, and then each takes its own constructor: \code{lassoWeights} fits with glmnet (\code{GlmnetOptions}) while - \code{lassosumRssWeights} runs pecotmr's lassosum solver - (\code{LassosumOptions}); \code{scadWeights} / \code{mcpWeights} / + \code{lassosumRssWeights} runs pecotmr's lassosum + (\code{LassosumOptions}); \code{enetWeights} / \code{ridgeWeights} fit + with glmnet too, while \code{enetRssWeights} / \code{ridgeRssWeights} + use \code{PenalizedRssOptions}; \code{scadWeights} / \code{mcpWeights} / \code{l0learnWeights} use ncvreg and L0Learn while their \code{*Rss} counterparts use \code{PenalizedRssOptions}; \code{dprGibbsWeights} uses RcppDPR and \code{sdprWeights} uses \code{SdprOptions}. Splitting them is diff --git a/man/twasPredict.Rd b/man/twasPredict.Rd index 2077a75f..7a7b4d1d 100644 --- a/man/twasPredict.Rd +++ b/man/twasPredict.Rd @@ -33,7 +33,7 @@ are derived from the names in \code{weightsList}, with "_weights" replaced by data(multiTraitData) X <- multiTraitData$X[, 1:4] colnames(X) <- sprintf("chr1:\%d:A:G", 100L * (1:4)) -twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), +twe <- TwasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", diff --git a/man/twasWeightsCv.Rd b/man/twasWeightsCv.Rd index a7d4337b..7db3ea5c 100644 --- a/man/twasWeightsCv.Rd +++ b/man/twasWeightsCv.Rd @@ -13,7 +13,7 @@ twasWeightsCv( weightMethods = NULL, maxNumVariants = NULL, variantsToKeep = NULL, - numThreads = 1, + BPPARAM = SerialParam(), verbose = 1, fitRetention = c("none", "slim", "full"), seed = NULL, @@ -49,10 +49,11 @@ maximum number of variants to use for CV purpose, to save computing time.} \item{variantsToKeep}{An optional integer to ensure that the listed variants are kept in the CV when there is a limit on the maxNumVariants to use.} -\item{numThreads}{The number of threads to use for parallel processing. If -set to -1, the function uses all available cores. If set to 0 or 1, no -parallel processing is performed. If set to 2 or more, parallel processing -is enabled with that many threads.} +\item{BPPARAM}{A \code{BiocParallelParam} the folds run on; +\code{SerialParam()} (default) runs them one at a time. Each draws from +its own random-number stream, seeded by \code{seed}, else by the param's +own \code{RNGseed}, else by one draw from the session RNG, so a run +gives the same numbers however many workers it has.} \item{verbose}{Integer controlling verbosity level: 0 = suppress all messages, 1 = suppress external package messages (default), 2 = show all @@ -66,11 +67,9 @@ for every other method the two behave alike.} \item{seed}{Integer or \code{NULL}. When supplied, seeds both the main-process RNG (fold partitioning, variant sub-sampling) and the -parallel fold-fitting RNG via the \code{BiocParallel} \code{RNGseed}, so -results are reproducible even under multi-threading. The main-process -seed is scoped to the call, so the session RNG is left as it was found. -\code{NULL} (default) does not seed at all and uses the historical -parallel default.} +streams the folds draw from (see \code{BPPARAM}). The main-process seed +is scoped to the call, so the session RNG is left as it was found. +\code{NULL} (default) seeds neither.} \item{dataDrivenPriorMatricesCv}{Optional list, one element per fold, of data-driven prior matrices for the mr.mash learner.} diff --git a/man/twasWeightsEntry.Rd b/man/twasWeightsEntry.Rd index 2f8c3d58..aafdbef8 100644 --- a/man/twasWeightsEntry.Rd +++ b/man/twasWeightsEntry.Rd @@ -24,7 +24,7 @@ Return the \code{TwasWeightsRow} for one \code{(study, context, trait, method)} row of a \code{TwasWeights} collection. } \examples{ -twe <- twasWeightsRow( +twe <- TwasWeightsRow( variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) tw <- TwasWeights(studyName = "s1", context = "brain", trait = "g1", diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 4ee09116..c0a348be 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -30,7 +30,7 @@ twasWeightsPipeline(data, ...) fitRetention = c("slim", "none", "full"), residualizationParam = ResidualizationParam(), weightsDataType = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, seed = NULL ) @@ -40,6 +40,7 @@ twasWeightsPipeline(data, ...) methods = NULL, contexts = NULL, traitId = NULL, + cisWindow = NULL, jointSpecification = NULL, fineMappingResult = NULL, twasWeights = NULL, @@ -69,7 +70,7 @@ twasWeightsPipeline(data, ...) nPCs = 10L, fitRetention = c("slim", "none", "full"), weightsDataType = NULL, - naAction = c("drop", "impute"), + phenotypeFilterParam = PhenotypeFilterParam(), verbose = 1, residualizationParam = ResidualizationParam(), crossValidationParam = CrossValidationParam(), @@ -92,9 +93,9 @@ 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 +\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.} @@ -107,23 +108,27 @@ 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.} +trait) pairs a per-context entry leaves out. In a MultiStudyQtlDataset +a study left with no trait selected sits out; the run is refused only +when no study or summary-statistics row has one.} \item{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 -\code{traitId}.} +\code{GRanges}. Mutually exclusive with \code{traitId}.} \item{cisWindow}{For QtlDataset: cis-window (bp) around each trait's genomic position when extracting variants. Required when \code{traitId} is -supplied. Mutually exclusive with \code{region}.} - -\item{genotypeFilterParam}{For QtlDataset: per-call genotype-filter -overrides, built with \code{\link{GenotypeFilterParam}}. Each field that is -set replaces the corresponding construct-time \code{\link{QtlDataset}} slot -for this call only (applied to a validated copy); a field left unset -leaves the stored value in place. Variant QC is a property of the data, -so these are applied identically here and in +supplied. Mutually exclusive with \code{region}. For QtlSumStats: +optional; each selected tuple is analysed over its \code{traitPos} +\eqn{\pm} \code{cisWindow}, within its \code{region}, which is then +the window its result records. Every selected tuple needs a +\code{traitPos}. A MultiStudyQtlDataset applies it to each of its +studies, individual-level or summary-statistics, as above.} + +\item{genotypeFilterParam}{For QtlDataset: which variants and samples the +run keeps, built with \code{\link{GenotypeFilterParam}}: its +\code{keepSamples} narrows the dataset once, and its other settings +apply to each extracted block. A field left unset filters nothing. +These are applied identically here and in \code{\link{fineMappingPipeline}} --- there is deliberately no TWAS-specific variant filter.} @@ -153,7 +158,9 @@ part.} 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 -instead of refitting.} +instead of refitting. Its fits and cross-validation are reused whole, +so a row narrowed since its fit warns (condition class +\code{pecotmrFitCoverage}).} \item{twasWeights}{Optional \code{\link{TwasWeights}} resume cache. For each requested \code{(study, context, trait, method)} tuple already present in @@ -217,8 +224,8 @@ components fitted per context when \code{usePCA = TRUE} (default of the returned object's contract. \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 + statistics, by \code{lasso}, \code{enet}, \code{ridge}, \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.} @@ -244,8 +251,12 @@ components fitted per context when \code{usePCA = TRUE} (default \item{weightsDataType}{Optional data-type label recorded on every \code{TwasWeightsRow$dataType} (e.g. \code{"expression"}).} -\item{naAction}{Character. How to handle missing values in the extracted -data.} +\item{phenotypeFilterParam}{The run's phenotype QC, built with +\code{\link{PhenotypeFilterParam}}: how missing phenotype values are +handled (unset drops the affected samples; \code{"impute"} fills each +trait's mean; a fit cannot take \code{"keep"}) and whether outlier +samples are dropped. Every fit of the run, joint ones included, reads +its phenotypes under it.} \item{verbose}{Verbosity (0 silent, 1 default, 2 includes external package messages).} @@ -265,9 +276,10 @@ above.} } \value{ A \code{\link{TwasWeights}} collection keyed by \code{(study, - 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. + context, trait, method)}. Each row's LD reference is none for + individual-level fits and that of the input row(s) for RSS-derived fits. + Its \code{seqinfo()} names the genome build the inputs name; inputs + naming different builds are refused. } \description{ S4-dispatched per-region pipeline for learning TWAS prediction weights. @@ -288,20 +300,25 @@ Method-restriction rules (enforced): (require at least two traits OR at least two contexts). \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. + \item \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. + \item \code{lasso}, \code{enet} and \code{ridge} are glmnet on + individual-level data and the penalized RSS solver on summary + statistics. \code{enet} mixes the two penalties at + \code{alpha = 0.5} unless the method's options set it, on either + input: \code{methods = list(enet = list(alpha = 0.3))}. } 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{ldReference} slot -is set automatically: \code{NULL} for individual-level fits, the input's -\code{ldReference} for RSS-derived fits. +Each row of the returned \code{\link{TwasWeights}} collection records the +LD reference its weights were learned against: none for individual-level +fits, the reference of the input row(s) for RSS-derived fits. Optionally a \code{QtlFineMappingResult} may be supplied as a source of pre-fit SuSiE / SuSiE-inf / SuSiE-ash objects; their stored fits are passed @@ -338,11 +355,10 @@ same shared partition. Individual-level genotypes reach every method centred and scaled to unit variance, so all the weights are on one scale and the recorded - \code{weight_standardized} says so. The scaling belongs to the - \code{QtlDataset} accessors rather than to this pipeline: - \code{\link{residualizedGenotypes}} applies it, governed by - \code{ResidualizationParam(scaleResiduals = )} per call with the - dataset's own \code{\link{scaleResiduals}} slot as the default. + \code{weight_standardized} says so. The residualization + (\code{\link{residualizedGenotypes}}) applies it, governed by + \code{ResidualizationParam(scaleResiduals = )}, which defaults to + \code{TRUE}. It is not cosmetic: measured through pecotmr's own entry points, every method returns coefficients on the scale of the \code{X} it was given diff --git a/man/updateObject-methods.Rd b/man/updateObject-methods.Rd new file mode 100644 index 00000000..d6c29fb8 --- /dev/null +++ b/man/updateObject-methods.Rd @@ -0,0 +1,112 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/RangedTupleList.R, R/AllClasses.R, +% R/ColocBoostResult.R, R/CtwasResult.R, R/H2Estimate.R, R/LdStatistic.R, +% R/QtlDataset.R, R/MultiStudyQtlDataset.R, R/twasWeights.R +\name{updateObject-methods} +\alias{updateObject-methods} +\alias{updateObject,RangedTupleList-method} +\alias{updateObject,SumStatsBase-method} +\alias{updateObject,FineMappingResultBase-method} +\alias{updateObject,ColocBoostResult-method} +\alias{updateObject,CtwasResult-method} +\alias{updateObject,H2Estimate-method} +\alias{updateObject,LdStatistic-method} +\alias{updateObject,QtlDataset-method} +\alias{updateObject,MultiStudyQtlDataset-method} +\alias{updateObject,TwasWeights-method} +\title{Update an Object Saved by an Earlier pecotmr} +\usage{ +\S4method{updateObject}{RangedTupleList}(object, ..., verbose = FALSE) + +\S4method{updateObject}{SumStatsBase}(object, ..., verbose = FALSE) + +\S4method{updateObject}{FineMappingResultBase}(object, ..., verbose = FALSE) + +\S4method{updateObject}{ColocBoostResult}(object, ..., verbose = FALSE) + +\S4method{updateObject}{CtwasResult}(object, ..., verbose = FALSE) + +\S4method{updateObject}{H2Estimate}(object, ..., verbose = FALSE) + +\S4method{updateObject}{LdStatistic}(object, ..., verbose = FALSE) + +\S4method{updateObject}{QtlDataset}(object, ..., verbose = FALSE) + +\S4method{updateObject}{MultiStudyQtlDataset}(object, ..., verbose = FALSE) + +\S4method{updateObject}{TwasWeights}(object, ..., verbose = FALSE) +} +\arguments{ +\item{object}{A collection (summary statistics, fine-mapping results, TWAS +weights, a colocalization or cTWAS result), a \code{QtlDataset}, a +\code{MultiStudyQtlDataset}, an \code{LdScore} or \code{LdEigen}, or an +\code{H2Estimate}.} + +\item{...}{Passed on to the inherited method.} + +\item{verbose}{Report the update.} +} +\value{ +\code{object} in the current representation. +} +\description{ +Bring an object saved by an earlier version of pecotmr up to + date. An up-to-date object is returned unchanged; an older one gets every + update below that applies to it, in the one call. + + \itemize{ + \item Collections keep their LD references per row: each distinct + reference once in the \code{ldReference} slot, and an + \code{ldReference} column naming the one every row uses (in + \code{outcomeInfo} for a \code{ColocBoostResult}). An object saved + when it held a single reference for all its rows is converted by + keying every row to that reference (for a \code{ColocBoostResult}, + every summary-statistic outcome), and one that held none by marking + every row LD-free. An object saved when the slot was named + \code{ldSketch} has it renamed first. + \item A genotype panel saved before panels recorded where their + genotypes come from (an LD reference, or a \code{QtlDataset}'s + genotypes) is read again from its files, as + \code{\link{readGenotypes}} reads them, and cut to the variants and + samples it held: a VCF, GDS or PLINK1 panel then reads through its + format's own backend, and a stochastic sketch records its real + sample count and allele frequencies. Only the files' variant and + sample lists, and a sketch's \code{.afreq}, are read; no genotypes + are, and nothing is written. An LD reference whose files cannot be + read again is kept as saved, with a warning, and updating again once + they are back finishes the job; a \code{QtlDataset} whose genotypes + cannot be is an error. + \item Collections name their elements by their identity tuple; one + saved without names gets them. + \item Summary statistics keep their QC settings in \code{qcOptions} + and each row's QC audit in a \code{qcAudit} column; ones saved with + both in one \code{qcInfo} record have it split between the two. + Their genome build is in \code{seqinfo()}; ones saved with it in a + \code{genome} slot have it moved there. + \item Fine-mapping results and TWAS weights record the variants each + row was fitted on in a \code{fitVariants} column; ones saved without + it have it filled in from their fits. + \item A \code{CtwasResult} holds one element per region; one saved as a + table of whole runs is rebuilt. + \item A \code{QtlDataset} no longer stores run settings (genotype + QC cutoffs, \code{scaleResiduals}); one saved with them has them + dropped, as the pipelines' \code{\link{GenotypeFilterParam}} and + \code{\link{ResidualizationParam}} now carry them. One saved with + its study in a \code{study} slot has it moved to \code{studyName}. + \item A \code{MultiStudyQtlDataset} is now a list of its studies; one + saved when it held them in a slot is rebuilt as one, its studies + updated too. + \item An \code{LdScore} or \code{LdEigen} saved before it could keep + an LD reference stores its blocks' LD itself, and gets none; one + saved with the reference's sample size as \code{nRef} has it moved + to \code{nSamples}. + \item An \code{H2Estimate} saved with its estimates under the slots' + earlier names (\code{h2}, \code{h2Se}, \code{local}, + \code{tauBlocks}) has them moved to the current ones. + } +} +\examples{ +data(qtlSumStatsExample) +# An object built by this version needs nothing. +identical(updateObject(qtlSumStatsExample), qtlSumStatsExample) +} diff --git a/man/variantColumnReplace.Rd b/man/variantColumnReplace.Rd index 9504b498..abf2180e 100644 --- a/man/variantColumnReplace.Rd +++ b/man/variantColumnReplace.Rd @@ -4,68 +4,51 @@ \alias{af<-} \alias{variantColumnReplace} \alias{maf<-} -\alias{nSamples<-} +\alias{sampleSize<-} \alias{af<-,SumStatsBase,numeric-method} -\alias{af<-,SumStatsBase,GRanges-method} \alias{maf<-,SumStatsBase,numeric-method} -\alias{maf<-,SumStatsBase,GRanges-method} -\alias{nSamples<-,SumStatsBase,numeric-method} -\alias{nSamples<-,SumStatsBase,GRanges-method} +\alias{sampleSize<-,SumStatsBase,numeric-method} \title{Replace a Per-Variant Column} \usage{ af(x, ...) <- value maf(x, ...) <- value -nSamples(x, ...) <- value +sampleSize(x, ...) <- value \S4method{af}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value -\S4method{af}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value - \S4method{maf}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value -\S4method{maf}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value - -\S4method{nSamples}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value - -\S4method{nSamples}{SumStatsBase,GRanges}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value +\S4method{sampleSize}{SumStatsBase,numeric}(x, studyName = NULL, context = NULL, trait = NULL, ...) <- value } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} \item{...}{Unused.} -\item{value}{A \code{numeric} vector (positional) or a \code{GRanges} -carrying \code{A1}/\code{A2} plus one value column (matched).} +\item{value}{A \code{numeric} vector, one value per variant in +\code{sumStats()} order.} -\item{studyName, context, trait}{Selectors pinning one entry; \code{context} -and \code{trait} are \code{QtlSumStats}-only.} +\item{studyName, context, trait}{Selectors pinning one study (every row of a +GWAS study) or one \code{QtlSumStats} entry; \code{context} and +\code{trait} are \code{QtlSumStats}-only.} } \value{ -The object, with that entry's column replaced. +The object, with the selection's column replaced. \code{sampleSize<-} + writes the per-variant \code{N}. } \description{ Supply or overwrite one per-variant column of a \code{GwasSumStats} / \code{QtlSumStats} entry after construction -- the usual case being an effect-allele frequency the source file did not - carry. Dispatch is on \code{value}: - \describe{ - \item{\code{numeric}}{positional: the vector is in the entry's own - variant order and must have exactly one value per variant. Length is - checked hard, because a recycled or truncated vector is otherwise - silently wrong.} - \item{\code{GRanges}}{matched: paired to the entry on - \code{(chrom, pos, A1, A2)} via \code{matchVariants}, so ordering - does not matter. \code{A1}/\code{A2} are \strong{required} in - \code{mcols()} so an allele swap can be detected, and exactly one - other \code{mcols} column carries the values. Entry variants the - replacement does not name are set \code{NA}.} - } - An allele swap sends \code{af} to \code{1 - af}, so \code{af<-} - complements a flipped match. \code{maf} is \code{min(af, 1 - af)} and - \code{nSamples} is a count, both swap-invariant, so neither is - complemented. + carry. The value is positional: a vector in \code{\link{sumStats}} + order for the selection -- a GWAS study split across rows is stitched, + as \code{sumStats()} returns it -- with exactly one value per variant. + Length is checked hard, because a recycled or truncated vector is + otherwise silently wrong. To take the values from a reference keyed by + variant instead, matched on \code{(chrom, pos, A1, A2)} and oriented to + the entry's alleles, use \code{\link{fillFromReference}}. } \examples{ data(qtlSumStatsExample) diff --git a/man/variantIds.Rd b/man/variantIds.Rd index 87703221..39bbb64b 100644 --- a/man/variantIds.Rd +++ b/man/variantIds.Rd @@ -25,17 +25,10 @@ variantIds(x, ...) context = NULL, trait = NULL, method = NULL, - region = NULL + blockId = NULL ) -\S4method{variantIds}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{variantIds}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) \S4method{variantIds}{FineMappingRow}(x) @@ -60,15 +53,8 @@ this trait; \code{NULL} matches all traits.} \item{method}{Character (length 1) or \code{NULL}. Restrict the selection to this fine-mapping / weight method; \code{NULL} matches all methods.} -\item{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.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} +\item{blockId}{GWAS fine-mapping results only: the \code{blockId} naming +one LD block of a fit; \code{NULL} matches every block.} } \value{ Character vector of variant IDs. @@ -76,7 +62,10 @@ Character vector of variant IDs. \description{ Extract variant ID vector from an object that carries one (e.g., \code{LdMatrix}, \code{FineMappingRow}, \code{TwasWeightsRow}) or from - one entry of a collection class selected by its identity tuple. + one entry of a collection class selected by its identity tuple. Every + class renders the same canonical \code{chrom:pos:A2:A1} id from each + variant's range and alleles; labels a source gave (an rsID, a file's own + spelling) stay in the \code{SNP} column of its ranges. } \examples{ data(qtlFineMappingExample) diff --git a/man/weights-methods.Rd b/man/weights-methods.Rd index d8127857..e9c1b3f9 100644 --- a/man/weights-methods.Rd +++ b/man/weights-methods.Rd @@ -42,7 +42,7 @@ Extract weights from a \code{TwasWeightsRow} or from one entry of a \code{TwasWeights} collection. } \examples{ -twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), +twe <- TwasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) weights(twe) diff --git a/man/weightsDataType.Rd b/man/weightsDataType.Rd index 93572c4b..1dc9d080 100644 --- a/man/weightsDataType.Rd +++ b/man/weightsDataType.Rd @@ -43,7 +43,7 @@ A character vector or NULL. Extract the data-type tag. } \examples{ -twe <- twasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), +twe <- TwasWeightsRow(variantIds = sprintf("chr1:\%d:A:G", 100L * (1:4)), weights = rep(0.1, 4), cvResult = list(rsq = 0.5), weightStandardized = FALSE) weightsDataType(twe) diff --git a/man/exportToBed.Rd b/man/writeBed.Rd similarity index 76% rename from man/exportToBed.Rd rename to man/writeBed.Rd index 4f93980c..3ac5c418 100644 --- a/man/exportToBed.Rd +++ b/man/writeBed.Rd @@ -1,19 +1,19 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/resultWriters.R -\name{exportToBed} -\alias{exportToBed} -\alias{exportToBed,list-method} -\alias{exportToBed,FineMappingResultBase-method} -\alias{exportToBed,TwasWeights-method} -\title{Export a result to a published BED table} +\name{writeBed} +\alias{writeBed} +\alias{writeBed,list-method} +\alias{writeBed,FineMappingResultBase-method} +\alias{writeBed,TwasWeights-method} +\title{Write a result to a published BED table} \usage{ -exportToBed(x, outputPath, ...) +writeBed(obj, filename, ...) -\S4method{exportToBed}{list}(x, outputPath, ...) +\S4method{writeBed}{list}(obj, filename, ...) -\S4method{exportToBed}{FineMappingResultBase}( - x, - outputPath, +\S4method{writeBed}{FineMappingResultBase}( + obj, + filename, schema = c("topLoci", "fsusie"), signalCutoff = 0.025, minPurity = NULL, @@ -23,19 +23,13 @@ exportToBed(x, outputPath, ...) extraColumns = NULL ) -\S4method{exportToBed}{TwasWeights}( - x, - outputPath, - coverage = NULL, - columns = NULL, - extraColumns = NULL -) +\S4method{writeBed}{TwasWeights}(obj, filename, coverage = NULL, columns = NULL, extraColumns = NULL) } \arguments{ -\item{x}{A \code{QtlFineMappingResult}, \code{GwasFineMappingResult} or +\item{obj}{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 +\item{filename}{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.} @@ -76,8 +70,7 @@ one. The fine-mapping views carry a long tail worth asking for (\code{grange_start} / \code{grange_end}, the legacy \code{gene} / \code{event} aliases, and whatever a custom build added); a \code{TwasWeights} element carries only its alleles and weight, so there -is nothing further to add unless the collection was built by hand. Not -accepted by the \code{"performance"} schema, which has no variant axis.} +is nothing further to add unless the collection was built by hand.} \item{extraColumns}{Optional NAMED list of trailing columns to append after the published schema. Each element is either length 1 (recycled across @@ -87,15 +80,15 @@ is the motivating case. Names that collide with a published column are an error rather than a silent overwrite.} } \value{ -\code{outputPath}, invisibly. +\code{filename}, invisibly. } \description{ Writes fine-mapping results or TWAS weights to a published FunGen-xQTL BED table, bgzipping and tabix-indexing the output when the path ends in \code{.gz} / \code{.bgz}. The tabular counterpart of -\code{\link{exportToVcf}}: the VCF is one record per variant with the models -as samples, while these tables are long-format, one row per published -observation. +\code{\link{writeGwasVcf}}: the VCF is one record per variant +with the models as samples, while these tables are long-format, one row per +published observation. } \details{ A \code{TwasWeights} writes one table, a row per (variant, weight column). @@ -113,26 +106,27 @@ Every table identifies the fit a row came from -- \code{study_ID}, \code{method} -- because these collections are keyed by that tuple and several of them are routinely folded into one output. -Cross-validation results are NOT exported, in any schema. They describe how +Cross-validation results are NOT written, in any schema. They describe how a model scored on held-out FOLDS; nothing about them is per-variant, and a published file has no data-secure way to express anything fold-level, because fold membership is sample-level information and sample names can be protected. They remain on the object, where \code{\link{cvResult}} returns -them and the caller tabulates whatever they need. For the same reason an -export REQUIRES the full-data fit: a cross-validation-only collection (what -\code{twasWeightsPipeline(fitFullData = FALSE)} produces) is refused rather -than written out empty. +them and the caller tabulates whatever they need. For the same reason +writing REQUIRES the full-data fit: a cross-validation-only collection +(what \code{twasWeightsPipeline(fitFullData = FALSE)} produces) is refused +rather than written out empty. } \examples{ data(qtlFineMappingExample) -exportToBed(qtlFineMappingExample, tempfile(fileext = ".bed")) -exportToBed( +writeBed(qtlFineMappingExample, tempfile(fileext = ".bed")) +writeBed( qtlFineMappingExample, tempfile(fileext = ".bed"), schema = "topLoci", columns = "all" ) data(twasWeightsExample) -exportToBed(twasWeightsExample, tempfile(fileext = ".bed")) +writeBed(twasWeightsExample, tempfile(fileext = ".bed")) } \seealso{ -\code{\link{exportToVcf}}, \code{\link{genomicOrder}} +\code{\link{writeGwasVcf}}, + \code{\link{readFineMappingResult}}, \code{\link{genomicOrder}} } diff --git a/man/writeGwasVcf.Rd b/man/writeGwasVcf.Rd new file mode 100644 index 00000000..83e991aa --- /dev/null +++ b/man/writeGwasVcf.Rd @@ -0,0 +1,134 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/resultWriters.R +\name{writeGwasVcf} +\alias{writeGwasVcf} +\alias{writeGwasVcf,list-method} +\alias{writeGwasVcf,GwasSumStats-method} +\alias{writeGwasVcf,FineMappingResultBase-method} +\alias{writeGwasVcf,TwasWeights-method} +\title{Write a result to VCF/BCF} +\usage{ +writeGwasVcf(obj, filename, ...) + +\S4method{writeGwasVcf}{list}(obj, filename, sampleName = NULL, ...) + +\S4method{writeGwasVcf}{GwasSumStats}(obj, filename, sampleName = NULL, studyName = NULL) + +\S4method{writeGwasVcf}{FineMappingResultBase}( + obj, + filename, + sampleName = NULL, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + splitByContext = FALSE, + splitByTrait = FALSE, + splitByBlock = FALSE +) + +\S4method{writeGwasVcf}{TwasWeights}( + obj, + filename, + sampleName = NULL, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL +) +} +\arguments{ +\item{obj}{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{filename}{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.} + +\item{...}{Additional arguments passed to methods.} + +\item{sampleName}{Name(s) for the VCF sample column(s). Default \code{NULL} +derives them from the object's identity tuple.} + +\item{studyName}{Character or \code{NULL}. Restrict the written records to +this study; \code{NULL} includes all studies.} + +\item{context}{Character or \code{NULL}. Restrict the written records to this +context; \code{NULL} includes all contexts.} + +\item{trait}{Character or \code{NULL}. Restrict the written records to this +trait; \code{NULL} includes all traits.} + +\item{method}{Character or \code{NULL}. Restrict the written records to this +method; \code{NULL} includes all methods.} + +\item{splitByContext}{Logical. If \code{TRUE}, write one VCF per context. +Default \code{FALSE}.} + +\item{splitByTrait}{Logical. If \code{TRUE}, write one VCF per trait. Default +\code{FALSE}.} + +\item{splitByBlock}{Logical. \code{GwasFineMappingResult} only: if +\code{TRUE}, write one VCF per LD block instead of joining a study's +blocks into one file. Default \code{FALSE}.} +} +\value{ +Invisible path(s) to the written file(s). +} +\description{ +Writes GWAS summary statistics, fine-mapping results or TWAS weights to a +GWAS-VCF-style file: one record per variant, one SAMPLE per study / fitted +model, and the per-variant statistics as FORMAT fields. The file is written +with VariantAnnotation's \code{\link[VariantAnnotation]{writeVcf}}, so that +package must be installed. +Supports bgzipped VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) additionally needs a +working \code{Rsamtools::asBcf()}, which recent Rsamtools releases disable, +so prefer .vcf.bgz. +} +\details{ +Which FORMAT fields are written depends on the input: +\describe{ + \item{\code{GwasSumStats}}{\code{ES} / \code{SE} / \code{EZ} / + \code{NS} / \code{AF} / \code{MAF} for one study, whichever its + variants carry.} + \item{a fine-mapping result}{the marginal fields (\code{ES}, + \code{SE}, \code{EZ}, \code{LP}, \code{NS}), the fit's own + (\code{AF}, \code{WGT}, \code{WGTSE}, \code{THETA}) and the + posterior ones (\code{PIP}, \code{LBF}, \code{LFSR}, and a + \code{CS}/\code{PUR} pair per credible-set coverage present).} + \item{\code{TwasWeights}}{\code{WGT}, the prediction weight.} +} + +Every fit the selectors match becomes a SAMPLE of ONE file: the records are +the union of their variants, the FORMAT schema is the union of their fields, +and a fit that did not include a variant -- or does not report a field -- +leaves those cells empty. So two methods over a region, or a dozen weight +methods for one gene, are compared by reading one file rather than a dozen. +Each sample is described in its own \code{##SAMPLE} header line, carrying +the fit's identity tuple and how many variants it contributed. +Cross-validation results are not written -- see \code{\link{writeBed}} for +why -- and writing requires the full-data fit. + +A GWAS study fine-mapped block by block is ONE fit, so its blocks are +joined into one sample. A \code{BID} FORMAT field then names each +variant's LD block -- credible-set indices are numbered within a block, +so a set is the \code{(BID, CS)} pair -- and the per-block header values +(block id, analysis window and whether it was given, \code{V}, +\code{cs_index}) are packed in block order, separated by \code{|}. +\code{\link{readFineMappingResult}} splits such a sample back into its +blocks. + +\code{splitByContext} / \code{splitByTrait} opt out of that and write one +file per context / trait, at a path decorated with the axis value, holding +the fits that share it. \code{splitByBlock} writes one file per LD block +of a GWAS result, each holding every fit's part of that block. +} +\examples{ +data(gwasSumStatsS4Example) +writeGwasVcf(gwasSumStatsS4Example, tempfile(fileext = ".vcf")) +} +\seealso{ +\code{\link{writeBed}}, \code{\link{readFineMappingResult}} +} diff --git a/man/z.Rd b/man/z.Rd index 9bb1dd83..206ac7ce 100644 --- a/man/z.Rd +++ b/man/z.Rd @@ -7,14 +7,7 @@ \usage{ z(x, ...) -\S4method{z}{SumStatsBase}( - x, - studyName = NULL, - context = NULL, - trait = NULL, - annotateSignificance = NULL, - ranges = NULL -) +\S4method{z}{SumStatsBase}(x, studyName = NULL, context = NULL, trait = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} @@ -31,12 +24,6 @@ this context; \code{NULL} matches all contexts.} \item{trait}{Character (length 1) or \code{NULL}. Restrict the selection to this trait; \code{NULL} matches all traits.} - -\item{annotateSignificance}{Optional correction-method name passed through to -\code{\link{sumStats}} (QTL only); \code{NULL} applies none.} - -\item{ranges}{A \code{GRanges} or \code{NULL} (default). Return only the -variants overlapping these ranges; \code{NULL} returns everything.} } \value{ Numeric vector of z-scores. diff --git a/pixi.toml b/pixi.toml index 5b2e1acb..b287e369 100644 --- a/pixi.toml +++ b/pixi.toml @@ -11,9 +11,10 @@ platforms = [ devtools_document = "cd $GITHUB_WORKSPACE; R -e 'devtools::document()'" devtools_test = "cd $GITHUB_WORKSPACE; R -e 'devtools::test(stop_on_failure = TRUE)'" codecov = "cd $GITHUB_WORKSPACE; R -e 'covr::codecov(quiet = FALSE)'" -rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck()'" -bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone()'" -bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck()'" +rcmdcheck = "cd $GITHUB_WORKSPACE; R -e 'rcmdcheck::rcmdcheck(error_on = \"error\", args = c(\"--no-manual\", \"--no-build-vignettes\"))'" +bioccheck_git_clone = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheckGitClone(\"quit-with-status\" = TRUE)'" +bioccheck = "cd $GITHUB_WORKSPACE; R -e 'BiocCheck::BiocCheck(\"quit-with-status\" = FALSE)'" +goodpractice = "cd $GITHUB_WORKSPACE; R -e 'goodpractice::gp(\".\")'" use_major_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"major\", push = FALSE)'" use_minor_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"minor\", push = FALSE)'" use_patch_version = "cd $GITHUB_WORKSPACE; R -e 'usethis::use_version(which = \"patch\", push = FALSE)'" diff --git a/src/cpp11.cpp b/src/cpp11.cpp index b0f643ba..e2144631 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -33,20 +33,6 @@ extern "C" SEXP _pecotmr_dentistIterativeImputeFactor(SEXP factorR, SEXP nSample 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 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) { @@ -117,8 +103,6 @@ static const R_CallMethodDef CallEntries[] = { {"_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}, diff --git a/src/lassosum_rss.cpp b/src/lassosum_rss.cpp deleted file mode 100644 index b5c776dc..00000000 --- a/src/lassosum_rss.cpp +++ /dev/null @@ -1,180 +0,0 @@ -// lassosum_rss.cpp — Coordinate descent for LASSO on RSS objective -// 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 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(). `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; - - int conv = 0; - for (int k = 0; k < maxiter; k++) { - 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) - ((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) / v; - if (beta(j) == bj) continue; - del = beta(j) - bj; - dlx = std::max(dlx, std::abs(del)); - // Update the running R * beta (analogous to yhat += del * X.col(j)) - ld.update(j, del); - } - cpp11::check_user_interrupt(); - if (dlx < thr) { - conv = 1; - break; - } - } - 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 lassosumRssCpp(const doubles& zR, - const list& LD, - double shrink, - const doubles& lambdaR, - double thr, - int maxiter) { - vec z = as_Col(zR); - vec lambda = as_Col(lambdaR); - - // Cache LD blocks once (avoid re-copying from R on every lambda iteration) - int n_blocks = LD.size(); - std::vector ld_blocks(n_blocks); - std::vector block_start(n_blocks), block_end(n_blocks); - int p = 0; - for (int b = 0; b < n_blocks; b++) { - ld_blocks[b] = as_Mat(doubles_matrix<>(LD[b])); - block_start[b] = p; - p += ld_blocks[b].n_rows; - block_end[b] = p - 1; - } - - if ((int)z.n_elem != p) - cpp11::stop("Length of z must equal total rows across all LD blocks."); - - 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++) { - // Block-wise coordinate descent — mirrors lassosum repelnet() - int out = 1; - 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 z_blk = z.subvec(s, e); - vec beta_blk = beta.subvec(s, e); - DenseLd ld(Rb, shrink, beta_blk); - - 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); - } - - beta_mat.col(i) = beta; - conv_vec(i) = out; - - // 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 += (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)); - } - - return lassosum_path_result(beta_mat, lambda, conv_vec, loss_vec, fbeta_vec); -} - -// 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/penalized_rss.cpp b/src/penalized_rss.cpp index cf23efb5..5bddb3e0 100644 --- a/src/penalized_rss.cpp +++ b/src/penalized_rss.cpp @@ -1,12 +1,18 @@ // penalized_rss.cpp — Coordinate descent for penalized regression on RSS objective // -// Generalizes lassosum_rss.cpp to support multiple penalties: +// The package's one RSS coordinate-descent solver, for the penalties // LASSO, MCP, SCAD, L0, L0L1, L0L2 +// lassosum (Mak et al 2017) is its LASSO at alpha = 1: the same updates in the +// same order, so the same coefficients bit for bit. // // Objective (smooth part): min_beta beta'R beta - 2 beta'z + penalty(beta) // 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). // +// LASSO, MCP and SCAD mix in a ridge term the way glmnet and ncvreg do: +// l1 = lambda * alpha, l2 = lambda * (1 - alpha), penalty = 2 P(beta; l1) + +// l2 beta'beta. LASSO with alpha < 1 is the elastic net, alpha = 0 ridge. +// // The coordinate descent update is identical across penalties; only the // proximal/thresholding operator differs. MCP/SCAD operators are ported // from ncvreg (Breheny & Huang 2011). L0 thresholding follows L0Learn @@ -39,11 +45,17 @@ static Penalty parse_penalty(const std::string& s) { // v = R_jj (diagonal of LD matrix for coordinate j) // l1, l2 = L1 and L2 penalty weights (for elastic net: l1 = lambda*alpha, // l2 = lambda*(1-alpha)) +// +// Each operator is the exact minimizer of the one-coordinate problem +// v b^2 - 2 z b + 2 P(b; l1) + l2 b^2, whose curvature is a = v + l2. ncvreg +// writes the curvature v (1 + l2), which is the same only when v = 1: a +// correlation matrix's diagonal, but not a diagonal the shrinkage or a +// genotype factor leaves slightly off 1. static inline double lasso_thresh(double z, double l1, double l2, double v) { double az = std::abs(z); if (az <= l1) return 0.0; - return std::copysign(az - l1, z) / (v * (1.0 + l2)); + return std::copysign(az - l1, z) / (v + l2); } // MCP (minimax concave penalty) — Breheny & Huang 2011 @@ -51,10 +63,11 @@ static inline double lasso_thresh(double z, double l1, double l2, double v) { static inline double mcp_thresh(double z, double l1, double l2, double gamma, double v) { double az = std::abs(z); + double a = v + l2; if (az <= l1) return 0.0; - if (az <= gamma * l1 * (1.0 + l2)) - return std::copysign(az - l1, z) / (v * (1.0 + l2 - 1.0 / gamma)); - return z / (v * (1.0 + l2)); + if (az <= gamma * l1 * a) + return std::copysign(az - l1, z) / (a - 1.0 / gamma); + return z / a; } // SCAD (smoothly clipped absolute deviation) — Fan & Li 2001 @@ -62,13 +75,14 @@ static inline double mcp_thresh(double z, double l1, double l2, static inline double scad_thresh(double z, double l1, double l2, double gamma, double v) { double az = std::abs(z); + double a = v + l2; if (az <= l1) return 0.0; - if (az <= l1 * (2.0 + l2)) - return std::copysign(az - l1, z) / (v * (1.0 + l2)); - if (az <= gamma * l1 * (1.0 + l2)) + if (az <= l1 * (1.0 + a)) + return std::copysign(az - l1, z) / a; + if (az <= gamma * l1 * a) return std::copysign(az - gamma * l1 / (gamma - 1.0), z) / - (v * (1.0 - 1.0 / (gamma - 1.0) + l2)); - return z / (v * (1.0 + l2)); + (a - 1.0 / (gamma - 1.0)); + return z / a; } // L0 (+L1+L2) — Hazimeh & Mazumder 2020 @@ -118,28 +132,29 @@ static double scad_penalty_single(double bj, double lambda, double gamma) { return lambda * lambda * (gamma + 1.0) / 2.0; } +// The penalty the thresholding operators minimize: 2 P(beta; l1) + l2 +// beta'beta, so MCP and SCAD are evaluated at l1 = lambda * alpha, the +// threshold the operators use, not at lambda. static double compute_penalty(Penalty pen, const vec& beta, double lambda, double alpha, double gamma, double lambda0, double lambda2) { double val = 0.0; double l1 = lambda * alpha; + double l2 = lambda * (1.0 - alpha); int p = beta.n_elem; switch (pen) { case PEN_LASSO: - val = 2.0 * l1 * sum(abs(beta)); + val = 2.0 * l1 * sum(abs(beta)) + l2 * dot(beta, beta); break; case PEN_MCP: for (int j = 0; j < p; j++) - val += 2.0 * alpha * mcp_penalty_single(beta(j), lambda, gamma); - // Add ridge part - if (alpha < 1.0) - val += lambda * (1.0 - alpha) * dot(beta, beta); + val += 2.0 * mcp_penalty_single(beta(j), l1, gamma); + val += l2 * dot(beta, beta); break; case PEN_SCAD: for (int j = 0; j < p; j++) - val += 2.0 * alpha * scad_penalty_single(beta(j), lambda, gamma); - if (alpha < 1.0) - val += lambda * (1.0 - alpha) * dot(beta, beta); + val += 2.0 * scad_penalty_single(beta(j), l1, gamma); + val += l2 * dot(beta, beta); break; case PEN_L0: { int nnz = 0; diff --git a/src/rss_ld.h b/src/rss_ld.h index e6911679..b49d0247 100644 --- a/src/rss_ld.h +++ b/src/rss_ld.h @@ -1,6 +1,6 @@ // rss_ld.h -- the LD a coordinate-descent RSS solve reads. // -// The solvers in lassosum_rss.cpp and penalized_rss.cpp minimise +// The solvers in 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 diff --git a/tests/testthat/helper-collectionAccessors.R b/tests/testthat/helper-collectionAccessors.R index 42df0fcd..4723aec3 100644 --- a/tests/testthat/helper-collectionAccessors.R +++ b/tests/testthat/helper-collectionAccessors.R @@ -1,5 +1,3 @@ -context("Collection-level accessors") - # =========================================================================== # Shared fixture # =========================================================================== @@ -29,7 +27,7 @@ context("Collection-level accessors") } .ca_makeFmEntry <- function(n = 3) { - fineMappingRow( + FineMappingRow( variantIds = paste0("chr1:", 100 * seq_len(n), ":A:G"), susieFit = list(payload = sprintf("fit_n=%d", n)), topLoci = .ca_makeTopLoci(n) diff --git a/tests/testthat/helper-fineMapping.R b/tests/testthat/helper-fineMapping.R new file mode 100644 index 00000000..8f9956cb --- /dev/null +++ b/tests/testthat/helper-fineMapping.R @@ -0,0 +1,146 @@ +# Fine-mapping rows and fits shared by the fine-mapping, collection, TWAS and +# result-writer tests. The fitted fixtures are promises: each is built once, +# on first use, so a test run that never reads one never pays for it. + +.makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { + p <- length(vids) + set.seed(11L) + lbf <- matrix( + rnorm(maxNumSingleEffects * p), + nrow = maxNumSingleEffects, + ncol = p + ) + colnames(lbf) <- vids + alpha <- lbfToAlpha(lbf) + pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) + FineMappingRow( + variantIds = vids, + susieFit = list( + pip = pip, + alpha = alpha, + lbf_variable = lbf, + mu = matrix(0, maxNumSingleEffects, p), + X_column_scale_factors = rep(1, p) + ), + topLoci = data.frame( + variant_id = vids, + pip = pip, + betahat = rep(0, p), + sebetahat = rep(1, p), + stringsAsFactors = FALSE + ) + ) +} + +# n = 100, p = 12 and L = 3 still give both credible sets (variants 3 and +# 10), bands and affected regions of either sign, at a fraction of the +# fitting time of a larger simulation. +.fsa_makeFit <- function(post_processing = "none") { + set.seed(1) + n <- 100L + p <- 12L + J <- 16L + X <- matrix( + rnorm(n * p), + n, + p, + dimnames = list( + paste0("s", seq_len(n)), + paste0("chr1:", seq_len(p) * 100, ":A:G") + ) + ) + b1 <- sin(seq(0, 2 * pi, length.out = J)) + b2 <- cos(seq(0, pi, length.out = J)) + Y <- X[, 3] %o% b1 + X[, 10] %o% b2 + matrix(rnorm(n * J, sd = 0.3), n, J) + colnames(Y) <- paste0("f", seq_len(J)) + suppressWarnings(fsusieR::susiF( + X = X, + Y = Y, + pos = seq_len(J), + L = 3, + post_processing = post_processing, + verbose = FALSE + )) +} + +.fsa_entry <- function(fit, purityVal = 0.85) { + vids <- names(fit$csd_X) + pipv <- if (!is.null(fit$pip)) { + as.numeric(fit$pip) + } else { + rep(0.1, length(vids)) + } + # Canonical CS labels + purity from the fit's CS membership, mirroring what + # The fsusie post-processing writes into a real FMR's topLoci + # (cs_95 / cs_95_purity). + cs95 <- rep("fsusie_0", length(vids)) + for (l in seq_along(fit$cs)) { + idx <- fit$cs[[l]] + if (is.numeric(idx)) { + idx <- as.integer(idx) + } + cs95[idx] <- paste0("fsusie_", l) + } + tl <- data.frame( + variant_id = vids, + pip = pipv, + cs_95 = cs95, + cs_95_purity = ifelse(cs95 != "fsusie_0", purityVal, 0), + stringsAsFactors = FALSE + ) + FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) +} + +# Each fit is made once and shared: susiF() is the slow step, it is +# deterministic, and the tests only read the fits. NULL without fsusieR. +delayedAssign( + ".fsa_fits", + if ( + requireNamespace("fsusieR", quietly = TRUE) && + requireNamespace("wavethresh", quietly = TRUE) + ) { + list(none = .fsa_makeFit("none"), TI = .fsa_makeFit("TI")) + } +) + +.twcv_foldFits <- function(seed = 11, fold = 3) { + set.seed(seed) + # Loaded here, not into the global environment: this runs as a helper's + # promise, whose environment does not see what data() puts there. + data("eqtlRegionExample", package = "pecotmr", envir = environment()) + X <- eqtlRegionExample$X[, 1:40] + y <- eqtlRegionExample$yRes + Y <- matrix(y, ncol = 1, dimnames = list(rownames(X), "t1")) + cv <- pecotmr:::.fmWeightsCv( + X, + Y, + tokens = "susie", + methodArgs = list(), + fold = fold, + verbose = 0, + seed = 1 + ) + list(X = X, Y = Y, cv = cv, slice = pecotmr:::.fmSliceCv(cv, "susie")) +} + +# Built once: each build runs a susie fit per fold, and the tests only read +# it. susieR is an Import, so the build needs no skip. +delayedAssign(".twcvFixture", suppressMessages(.twcv_foldFits())) + +.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 +} diff --git a/tests/testthat/helper-fitCoverage.R b/tests/testthat/helper-fitCoverage.R new file mode 100644 index 00000000..e3e58b61 --- /dev/null +++ b/tests/testthat/helper-fitCoverage.R @@ -0,0 +1,20 @@ +# The fit-coverage warning an expression raises, or the expression's value +# when it raises none. Every other warning is muffled: a pipeline run on test +# data warns about things these checks do not look at. +.fitCoverageCondition <- function(expr) { + suppressWarnings(tryCatch(expr, pecotmrFitCoverage = identity)) +} + +# The message of every fit-coverage warning an expression raises, run to the +# end; other warnings are muffled. +.fitCoverageMessages <- function(expr) { + msgs <- character(0) + suppressWarnings(withCallingHandlers( + expr, + pecotmrFitCoverage = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + } + )) + msgs +} diff --git a/tests/testthat/helper-genotypeHandle.R b/tests/testthat/helper-genotypeHandle.R index 39fcaccb..d0c71b16 100644 --- a/tests/testthat/helper-genotypeHandle.R +++ b/tests/testthat/helper-genotypeHandle.R @@ -11,3 +11,46 @@ readGenotypeHandle <- function(path, format = NULL, ...) { pecotmr:::.readGenotypeHandle(path, format = format, ...) } + +.gh_pgenHandle <- function() { + skip_if_not_installed("pgenlibr") + readGenotypeHandle(test_path("test_data", "test_variants.pgen")) +} + +.sk_panel <- function() { + readGenotypes( + test_path("test_data", "test_variants"), + format = "plink1" + ) +} + +.ssQ_makeHandle <- function(snp_n = 8L, n_samples = 60L) { + new( + "GenotypeHandle", + path = "/tmp/sketch", + format = "plink2", + snpInfo = data.frame( + SNP = paste0("rs", seq_len(snp_n)), + CHR = rep("chr1", 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 + ) +} + +# A panel whose SNP ids follow the formatVariantId convention (chr:pos:A2:A1), +# as real genotype LD sketches do, so a re-keyed entry SNP resolves against it. +.ssQ_makeHandleVid <- function(snp_n = 8L, n_samples = 60L) { + h <- .ssQ_makeHandle(snp_n, n_samples) + h@snpInfo$SNP <- paste0("chr1:", snpInfo(h)$BP, ":G:A") + h +} + +.dose <- function(panel) { + unname(as.matrix(SummarizedExperiment::assay(panel, "dosage"))) +} diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index a685dce5..5150b6a9 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -1,34 +1,11 @@ -# Tests for S4 classes (h2_classes.R), GwasSumStats (h2_sumstats.R), -# and AnnotationMatrix (h2Annotations.R) +# Fixtures shared by the LD-statistic tests (LdEigen, LdScore, LdStatistic), +# the heritability tests (h2EstimationWrappers, H2Estimate) and +# test_genotypeHandle.R. # ============================================================================= # Test data helpers # ============================================================================= -makeTestGRanges <- function(n = 10) { - GenomicRanges::GRanges( - seqnames = rep("chr1", n), - ranges = IRanges::IRanges( - start = seq(1000, by = 100, length.out = n), - width = 1L - ) - ) -} - -makeTestSumstatsDf <- function(n = 50) { - set.seed(42) - data.frame( - SNP = paste0("rs", seq_len(n)), - CHR = rep("1", n), - BP = seq(1000, by = 100, length.out = n), - A1 = rep("A", n), - A2 = rep("G", n), - Z = rnorm(n), - N = rep(10000, n), - stringsAsFactors = FALSE - ) -} - makeTestLdBlocks <- function() { blocks_gr <- GenomicRanges::GRanges( seqnames = c("chr1", "chr1"), @@ -40,7 +17,7 @@ makeTestLdBlocks <- function() { makeTestSnpInfo <- function(n = 10) { data.frame( SNP = paste0("rs", seq_len(n)), - CHR = rep("1", n), + CHR = rep("chr1", n), BP = seq(1000, by = 100, length.out = n), A1 = rep("A", n), A2 = rep("G", n), @@ -48,134 +25,6 @@ makeTestSnpInfo <- function(n = 10) { ) } -makeTestAnnotationMeta <- function() { - data.frame( - name = c("base", "enhancer", "promoter"), - tier = c("baseline", "candidate", "candidate"), - type = c("binary", "binary", "continuous"), - stringsAsFactors = FALSE - ) -} - -# Bridge helper: turn the legacy per-study data.frame shape into a -# single-row GwasSumStats collection using the new API. Keeps the bulk of -# the per-accessor tests below readable. -.testGenotypeHandle <- function() { - new( - "GenotypeHandle", - path = "/tmp/test", - format = "plink2", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) -} - -.dfToSumstatsGr <- function(df) { - chrs <- as.character(df$CHR) - if (!all(grepl("^chr", chrs))) { - chrs <- paste0("chr", sub("^chr", "", chrs)) - } - gr <- GenomicRanges::GRanges( - seqnames = chrs, - ranges = IRanges::IRanges(start = as.integer(df$BP), width = 1L) - ) - mc <- df[, setdiff(colnames(df), c("CHR", "BP")), drop = FALSE] - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mc) - gr -} - -makeGwasSumStatsFromDf <- function( - df, - traitName = "test", - genome = "hg19", - varY = NA_real_ -) { - required <- c("SNP", "A1", "A2", "Z", "N") - missingCols <- setdiff(required, colnames(df)) - if (length(missingCols) > 0L) { - stop("Missing required columns: ", paste(missingCols, collapse = ", ")) - } - keep <- stats::complete.cases(df[, required, drop = FALSE]) - if (!all(keep)) { - message(sprintf( - "Removed %d SNPs with missing required-column values.", - sum(!keep) - )) - } - df <- df[keep, , drop = FALSE] - if (is.null(varY)) { - varY <- NA_real_ - } - GwasSumStats( - studyName = traitName, - entry = list(.dfToSumstatsGr(df)), - genome = genome, - ldReference = .testGenotypeHandle(), - varY = varY - ) -} - -# A handle over a real (fake-path) variant set, so tests can build the -# per-block LD panels a block-parallel pipeline produces: same genotype source, -# each narrowed to its own variants. -.blockGenotypeHandle <- function(bp, path = "/tmp/test.pgen") { - new( - "GenotypeHandle", - path = path, - format = "plink2", - snpInfo = data.frame( - SNP = paste0("chr1:", bp, ":A:G"), - CHR = rep("1", length(bp)), - BP = as.integer(bp), - A1 = rep("G", length(bp)), - A2 = rep("A", length(bp)), - fileIdx = seq_along(bp), - stringsAsFactors = FALSE - ), - nSamples = 10L, - sampleIds = paste0("s", seq_len(10)), - pgenPtr = NULL - ) -} - -# One LD block's worth of GWAS summary statistics: `n` variants starting at -# `start`, carrying a QC record and an LD panel narrowed to just those -# variants (what a per-block pipeline step writes out). -makeGwasBlock <- function( - blockId, - start, - n = 5L, - genome = "hg19", - qcOptions = list(mafCutoff = 0.01) -) { - bp <- seq(start, by = 100L, length.out = n) - df <- data.frame( - SNP = paste0("chr1:", bp, ":A:G"), - CHR = rep("1", n), - BP = bp, - A1 = rep("A", n), - A2 = rep("G", n), - Z = seq_len(n) / 10, - N = rep(1000L, n), - stringsAsFactors = FALSE - ) - obj <- GwasSumStats( - studyName = "trait1", - entry = list(.dfToSumstatsGr(df)), - genome = genome, - ldReference = .blockGenotypeHandle(bp), - blockId = blockId, - qcInfo = list( - timestamp = NA_character_, - options = qcOptions, - entryAudit = list(list(variantsIn = n, block = blockId)) - ) - ) - obj -} - # ============================================================================= # LdMatrix fixtures for buildLdEigen() / buildLdScore() @@ -240,10 +89,12 @@ makeTestLdMatrixBlocks <- function( 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)]]) + blocks <- GenomicRanges::GRanges( + "chr21", + IRanges::IRanges( + start = map_int(cuts, function(i) pos[[min(i)]]), + end = map_int(cuts, function(i) pos[[max(i)]]) + ) ) ld <- map(cuts, function(i) { LdMatrix( @@ -255,38 +106,47 @@ makeTestLdMatrixBlocks <- function( 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), +makeTestH2Estimate <- function(with_enrichment = TRUE) { + enrich <- if (with_enrichment) { data.frame( - name = colnames(mat), - tier = c("baseline", "baseline", "candidate"), - type = c("binary", "continuous", "binary") - ), - genome = "hg19" - ) -} + annotation = c("annot1", "annot2"), + tau = c(1e-7, 2e-7), + tauSe = c(5e-8, 6e-8), + enrichment = c(2.0, 3.0), + enrichmentSe = c(0.5, 0.7), + enrichmentP = c(0.01, 0.001), + propH2 = c(0.3, 0.5), + propSnps = c(0.15, 0.17), + stringsAsFactors = FALSE + ) + } else { + NULL + } -# 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) - })) + set.seed(55) + annotationJackknifeCoefs <- if (with_enrichment) { + matrix( + rnorm(20), + nrow = 10, + ncol = 2, + dimnames = list(NULL, c("annot1", "annot2")) + ) + } else { + NULL + } + + new( + "H2Estimate", + estimate = 0.3, + estimateSe = 0.05, + intercept = 1.01, + interceptSe = 0.02, + localBlocks = NULL, + enrichment = enrich, + annotationJackknifeCoefs = annotationJackknifeCoefs, + scoreStats = NULL, + method = "lder", + nSnps = 100L, + traitName = "test" + ) } diff --git a/tests/testthat/helper-mash.R b/tests/testthat/helper-mash.R index ccddab06..36a10f26 100644 --- a/tests/testthat/helper-mash.R +++ b/tests/testthat/helper-mash.R @@ -44,3 +44,9 @@ mashTinyPrior <- function(k = 3L) { ) )) } + +# The fixture and one fitted model, built on first use and shared by the +# tests that only read them. Every mash() call forces three garbage +# collections (mashr times each step with system.time()), which costs far +# more than the fit itself. +delayedAssign(".mwSs", mashFixture()) diff --git a/tests/testthat/helper-resultIo.R b/tests/testthat/helper-resultIo.R new file mode 100644 index 00000000..f43e6dca --- /dev/null +++ b/tests/testthat/helper-resultIo.R @@ -0,0 +1,81 @@ +# Fine-mapping and GWAS results that the writer, reader and loader tests +# publish and read back. + +# One block's fit: three variants from `offset`, its effects' V and the +# effects that formed credible sets. +.rw_blockFit <- function(offset, V, csIndex) { + FineMappingRow( + variantIds = paste0("chr1:", offset + 100 * (1:3), ":A:G"), + susieFit = list(V = V, sets = list(cs_index = csIndex)), + topLoci = .sc_makeTopLoci(3, offset = offset) + ) +} + +.rw_blockedGwasFmr <- function( + dataType = NULL, + blockId = c("chr1_1_5000", "chr1_5001_20000") +) { + GwasFineMappingResult( + studyName = c("g1", "g1"), + method = c("susie", "susie"), + entry = list( + .rw_blockFit(0L, c(0.1, 0.2), 1L), + .rw_blockFit(10000L, c(0.3, 0.4), 2L) + ), + blockId = blockId, + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 5001L), c(5000L, 20000L)) + ), + dataType = dataType + ) +} + +# The same two blocks of one fit, the first given its window and the second +# not, so its window is its variants' span. +.rw_mixedGwasFmr <- function() { + combineFineMappingResults( + GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(.rw_blockFit(0L, c(0.1, 0.2), 1L)), + blockId = "chr1_1_5000", + region = GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 5000L)) + ), + GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(.rw_blockFit(10000L, c(0.3, 0.4), 2L)), + blockId = "b2" + ) + ) +} + +.rw_sampleLines <- function(path) { + grep("^##SAMPLE", readLines(path), value = TRUE) +} + +# @noRd +.ezss <- function(supplied) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 200L), width = 1L) + ) + cols <- S4Vectors::DataFrame( + SNP = c("chr1:100:A:G", "chr1:200:C:T"), + A1 = c("G", "T"), + A2 = c("A", "C"), + Z = c(2.5, -1.2), + N = c(1000L, 1000L), + BETA = c(0.25, -0.12), + SE = c(0.1, 0.1) + ) + if (!is.null(supplied)) { + cols$z_supplied <- rep(supplied, 2L) + } + GwasSumStats( + studyName = "s", + entry = list(S4Vectors::`mcols<-`(gr, value = cols)), + genome = "hg38" + ) +} diff --git a/tests/testthat/helper-s4Constructors.R b/tests/testthat/helper-s4Constructors.R index 2b161b10..ce94f714 100644 --- a/tests/testthat/helper-s4Constructors.R +++ b/tests/testthat/helper-s4Constructors.R @@ -1,5 +1,3 @@ -context("s4Constructors") - # =========================================================================== # Shared test helpers # =========================================================================== @@ -11,7 +9,7 @@ context("s4Constructors") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -49,26 +47,13 @@ context("s4Constructors") } .sc_makeFineMappingRow <- function(n = 3, offset = 0L) { - fineMappingRow( + FineMappingRow( variantIds = paste0("chr1:", offset + 100 * seq_len(n), ":A:G"), susieFit = list(fake = TRUE), topLoci = .sc_makeTopLoci(n, offset = offset) ) } -.sc_makeTwasWeightsRow <- function( - p = 5L, - weightStandardized = FALSE, - weightsDataType = "expression" -) { - twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), - weights = rnorm(p), - weightStandardized = weightStandardized, - weightsDataType = weightsDataType - ) -} - # =========================================================================== # FineMappingRow # =========================================================================== @@ -97,3 +82,176 @@ context("s4Constructors") colData = cd ) } + +.qtlMakeGenotypeHandle <- function() { + new( + "GenotypeHandle", + path = "/tmp/test", + format = "plink2", + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ) +} + +.qtlMakeEntryGr <- function( + n = 5, + chr = "chr1", + start_at = 100L, + step = 100L, + with_maf = FALSE +) { + gr <- GenomicRanges::GRanges( + seqnames = rep(chr, n), + ranges = IRanges::IRanges( + start = seq(start_at, by = step, length.out = n), + width = 1L + ) + ) + mcols_list <- list( + SNP = paste0("rs", seq_len(n)), + A1 = rep("A", n), + A2 = rep("G", n), + Z = seq(1.0, by = 0.5, length.out = n), + N = rep(1000L, n) + ) + if (with_maf) { + mcols_list$MAF <- seq(0.05, by = 0.01, length.out = n) + } + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcols_list) + gr +} + +.qtlMakeOne <- function( + studyName = "study1", + context = "Cortex", + trait = "ENSG001", + n = 5, + varY = NA_real_, + with_maf = FALSE, + qcOptions = list(), + genome = "hg19" +) { + QtlSumStats( + studyName = studyName, + context = context, + trait = trait, + entry = list(.qtlMakeEntryGr(n, with_maf = with_maf)), + genome = genome, + ldReference = .qtlMakeGenotypeHandle(), + varY = varY, + qcOptions = qcOptions + ) +} + +.cbp_makeHandle <- function(snp_n = 6L, n_samples = 30L, sample_prefix = "s") { + new( + "GenotypeHandle", + path = "/tmp/cb", + format = "plink2", + snpInfo = data.frame( + SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), + CHR = rep("chr1", 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(sample_prefix, seq_len(n_samples)), + pgenPtr = NULL + ) +} + +.afm_df <- function(freqcol, val) { + d <- data.frame( + chrom = "chr1", + pos = 100L, + variant_id = "chr1:100:A:G", + A1 = "A", + A2 = "G", + z = 2.5, + n_sample = 1000, + stringsAsFactors = FALSE + ) + d[[freqcol]] <- val + d +} + +.afm_cm <- function(...) { + c( + chrom = "chrom", + pos = "pos", + variant_id = "variant_id", + A1 = "A1", + A2 = "A2", + z = "z", + n_sample = "n_sample", + ... + ) +} + +# A deterministic per-gene QtlSumStats: one row per gene carrying the regional +# summary as row columns (p_beta / beta shapes / n_variants), each entry a +# per-variant GRanges (P / af / tss_distance / tes_distance, plus the `qvalue` +# the qvalue SNP significance query reads, with v1 tracking the gene signal). +# Deterministic so qvalue::qvalue sees a stable p-value distribution. +# emptyIdx gene indices whose entry is an empty GRanges (no p-values), for +# the "skip genes with no variants" branch; the p_beta +# distribution is unchanged, so qvalue::qvalue still estimates +# pi0 on its default path. +.qapFixture <- function(nVar = 50L, nVarFilt = 30L, emptyIdx = integer(0)) { + # 6 strong signal p_beta + a deterministic uniform null (ppoints) so + # qvalue::qvalue estimates pi0 on its default path (no fallback needed). + # 18 null genes keep its smoother well clear of failing (it does by 10). + pBeta <- c(10^(-c(8, 7, 6, 5, 4, 3)), stats::ppoints(18)) + G <- length(pBeta) + entries <- map(seq_len(G), function(i) { + if (i %in% emptyIdx) { + return(GenomicRanges::GRanges()) + } # no variants + k <- 4L + pv <- c(pBeta[i] / 5, 0.2, 0.5, 0.8) # min tracks the gene signal + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = seq(1000L, by = 50L, length.out = k), + width = 1L + ) + ) + mc <- S4Vectors::DataFrame( + SNP = paste0("g", i, "_v", seq_len(k)), + A1 = "A", + A2 = "G", + P = pv, + af = c(0.30, 0.20, 0.005, 0.40), # v3 fails MAF 0.01 + tss_distance = c(0L, 500L, 900000L, 2000000L), # v4 outside 1Mb cis + tes_distance = c(0L, 500L, 900000L, 2000000L), + qvalue = c(pBeta[i] / 5, 0.30, 0.60, 0.90) + ) + S4Vectors::mcols(gr) <- mc + gr + }) + QtlSumStats( + study = rep("s", G), + context = rep("brain", G), + trait = paste0("g", seq_len(G)), + entry = entries, + genome = "hg19", + extraCols = list( + n_variants = rep(nVar, G), + n_variants_filtered = rep(nVarFilt, G), + p_beta = pBeta, + beta_shape1 = rep(1, G), + beta_shape2 = rep(200, G) + ) + ) +} + +# The default fixture is 24 genes of GRanges + mcols; building it, like every +# postprocess / significantQtls call, costs time in proportion to the gene +# count, so the tests share one instance, built on first use. S4 objects are +# copy-on-modify, so that is safe; tests needing new entries still call +# .qapFixture() with arguments. +delayedAssign(".qapDefaultFixture", .qapFixture()) diff --git a/tests/testthat/helper-savedObjects.R b/tests/testthat/helper-savedObjects.R new file mode 100644 index 00000000..3b4fbfc0 --- /dev/null +++ b/tests/testthat/helper-savedObjects.R @@ -0,0 +1,69 @@ +# Objects as an earlier pecotmr saved them, for the updateObject() tests of +# the collections (test_RangedTupleList.R, test_AllClasses.R, +# test_twasWeights.R, test_ColocBoostResult.R), test_LdStatistic.R, +# test_H2Estimate.R, test_QtlDataset.R and the panel tests in +# test_genotypeIo.R. + +# `x` with each slot in `renames` (old name = current name) stored under its +# old name, as an object saved before the rename holds it: R stores a slot as +# an attribute, and a NULL one as a placeholder symbol, which `slot<-` writes. +.savedUnder <- function(x, renames) { + reduce2(names(renames), unname(renames), .savedUnderName, .init = x) +} + +.savedUnderName <- function(x, old, new) { + value <- methods::slot(x, new) + attr(x, new) <- NULL + `slot<-`(x, old, check = FALSE, value = value) +} + +# A collection as saved before its references became per-row: one reference +# (or NULL) in the slot and no row key. +.savedWithOneLdRef <- function(x, ref) { + old <- `slot<-`(x, "ldReference", check = FALSE, value = ref) + md <- attr(old, "elementMetadata") + md[["ldReference"]] <- NULL + attr(old, "elementMetadata") <- md + old +} + +# ...and as saved before the slot was renamed, holding that reference as +# `ldSketch`. +.savedWithLdSketch <- function(x, ref) { + .savedUnder(.savedWithOneLdRef(x, ref), c(ldSketch = "ldReference")) +} + +# A genotype panel as saved before panels recorded where their genotypes come +# from: its dosages read through a GenotypeHandle's GhSeed at `path` -- one +# claiming `format`, which may be a format a handle no longer reads -- with +# no metadata and only the SNP / A1 / A2 variant columns, and reading the +# per-chromosome files `chromPaths` when given. Its variants, samples and +# sample data are copied from `panel`, today's panel over the same files. +.savedHandlePanel <- function(panel, path, format, chromPaths = character(0)) { + rr <- SummarizedExperiment::rowRanges(panel) + handle <- methods::new( + "GenotypeHandle", + path = path, + format = "plink2", + snpInfo = data.frame( + SNP = rownames(panel), + CHR = as.character(GenomicRanges::seqnames(rr)), + BP = GenomicRanges::start(rr), + A1 = rr$A1, + A2 = rr$A2 + ), + nSamples = ncol(panel), + sampleIds = colnames(panel), + pgenPtr = NULL, + chromPaths = chromPaths + ) + old <- `slot<-`(handle, "format", check = FALSE, value = format) + SummarizedExperiment::SummarizedExperiment( + assays = list(dosage = genotypeDelayedArray(old)), + rowRanges = S4Vectors::`mcols<-`( + rr, + value = S4Vectors::mcols(rr)[c("SNP", "A1", "A2")] + ), + colData = SummarizedExperiment::colData(panel) + ) +} diff --git a/tests/testthat/helper-showMethods.R b/tests/testthat/helper-showMethods.R index 1714e1be..5aecda74 100644 --- a/tests/testthat/helper-showMethods.R +++ b/tests/testthat/helper-showMethods.R @@ -1,5 +1,3 @@ -context("show methods") - # =========================================================================== # Shared fixtures # =========================================================================== @@ -11,7 +9,7 @@ context("show methods") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -44,7 +42,7 @@ context("show methods") if (with_cs) { tl$cs_95 <- paste0("susie_", c(1L, 1L, 0L)[seq_len(n)]) } - fineMappingRow( + FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl @@ -52,7 +50,7 @@ context("show methods") } .sh_makeTwEntry <- function(p = 4, weightStandardized = FALSE) { - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = rep(0.1, p), cvResult = list(rsq = 0.5), diff --git a/tests/testthat/helper-sldsc.R b/tests/testthat/helper-sldsc.R index dd6d7e93..787a46bb 100644 --- a/tests/testthat/helper-sldsc.R +++ b/tests/testthat/helper-sldsc.R @@ -1,222 +1,5 @@ -# Shared S-LDSC fixture generators for test_sldscWrapper.R (helper unit tests) -# and test_sldscPostprocessingPipeline.R (integration tests). -# -# Fixture convention: -# - 2 chromosomes (1, 2), 50 SNPs each -> 100 total -# - 2 target annotations: "annot_A" (binary), "annot_B" (continuous) -# - baseline annotations (baselineLD_0 ..) in joint run -# - 10 jackknife blocks -# - Polyfun appends "_0" to target annotation names in .results - -# Create a single .annot.gz file for one chromosome. -# Real polyfun .annot.gz files have CHR, SNP, BP, CM + annotation columns only -# (no MAF/A1/A2 -- those come from the .frq / PLINK files). -.makeAnnotGz <- function(dir, chrom, nSnps = 50) { - df <- data.frame( - CHR = chrom, - SNP = paste0("rs", (chrom - 1L) * 100L + seq_len(nSnps)), - BP = seq_len(nSnps) * 1000L, - CM = seq_len(nSnps) * 0.01, - annot_A = sample(c(0L, 1L), nSnps, replace = TRUE), - annot_B = rnorm(nSnps, 2, 0.5), - stringsAsFactors = FALSE - ) - path <- file.path(dir, sprintf("target.%d.annot.gz", chrom)) - gz <- gzfile(path, "wb") - vroom::vroom_write(df, gz, delim = "\t") - close(gz) - invisible(df) -} - -# Create a PLINK .frq file for one chromosome -.make_frq <- function(dir, chrom, plinkName = "ref_chr", nSnps = 50) { - df <- data.frame( - CHR = chrom, - SNP = paste0("rs", (chrom - 1L) * 100L + seq_len(nSnps)), - A1 = "A", - A2 = "G", - MAF = runif(nSnps, 0.01, 0.49), - NCHROBS = 200L, - stringsAsFactors = FALSE - ) - path <- file.path(dir, sprintf("%s%d.frq", plinkName, chrom)) - vroom::vroom_write(df, path, delim = "\t") - invisible(df) -} - -# Create the three polyfun output files (.results, .log, .part_delete) -# for a single-target run. Real polyfun output includes baseline categories -# even in single-target mode, so we add 2 dummy baseline categories. -.makePolyfunSingle <- function( - dir, - prefix, - target_name, - nBlocks = 10, - h2g = 0.3, - tau = 1e-7, - enrichment = 2.5, - n_baseline = 2 -) { - target_cat <- paste0(target_name, "_0") - baseline_cats <- paste0("baselineLD_", seq_len(n_baseline) - 1L) - all_cats <- c(target_cat, baseline_cats) - n_cats <- length(all_cats) - - taus_all <- c(tau, rep(1e-8, n_baseline)) - enrichments_all <- c(enrichment, rep(1.0, n_baseline)) - - results <- data.frame( - Category = all_cats, - Coefficient = taus_all, - Coefficient_std_error = abs(taus_all) * 0.3, - Enrichment = enrichments_all, - Enrichment_std_error = enrichments_all * 0.2, - Enrichment_p = rep(0.01, n_cats), - `Prop._h2` = c(0.15, rep(0.425, n_baseline)), - `Prop._SNPs` = c(0.06, rep(0.47, n_baseline)), - check.names = FALSE, - stringsAsFactors = FALSE - ) - vroom::vroom_write(results, paste0(prefix, ".results"), delim = "\t") - - writeLines( - c( - "Analysis started at 2024-01-01", - sprintf("Total Observed scale h2: %g (0.05)", h2g), - "Analysis finished" - ), - paste0(prefix, ".log") - ) - - blocks <- matrix( - rnorm( - nBlocks * n_cats, - mean = rep(taus_all, each = nBlocks), - sd = abs(rep(taus_all, each = nBlocks)) * 0.5 - ), - nrow = nBlocks, - ncol = n_cats - ) - colnames(blocks) <- all_cats - vroom::vroom_write( - as.data.frame(blocks), - paste0(prefix, ".part_delete"), - delim = "\t" - ) - invisible(NULL) -} - -# Create polyfun output files for a joint run (target + baseline annotations) -.makePolyfunJoint <- function( - dir, - prefix, - target_names, - n_baseline = 3, - nBlocks = 10, - h2g = 0.3 -) { - target_cats <- paste0(target_names, "_0") - baseline_cats <- paste0("baselineLD_", seq_len(n_baseline) - 1L) - all_cats <- c(target_cats, baseline_cats) - n_cats <- length(all_cats) - - taus <- c(rep(1e-7, length(target_cats)), rep(1e-8, n_baseline)) - enrichments <- c(rep(2.0, length(target_cats)), rep(1.0, n_baseline)) - - results <- data.frame( - Category = all_cats, - Coefficient = taus, - Coefficient_std_error = abs(taus) * 0.3, - Enrichment = enrichments, - Enrichment_std_error = enrichments * 0.2, - Enrichment_p = rep(0.05, n_cats), - `Prop._h2` = rep(1 / n_cats, n_cats), - `Prop._SNPs` = rep(1 / n_cats, n_cats), - check.names = FALSE, - stringsAsFactors = FALSE - ) - vroom::vroom_write(results, paste0(prefix, ".results"), delim = "\t") - - writeLines( - c( - "Analysis started at 2024-01-01", - sprintf("Total Observed scale h2: %g (0.05)", h2g), - "Analysis finished" - ), - paste0(prefix, ".log") - ) - - blocks <- matrix( - rnorm( - nBlocks * n_cats, - mean = rep(taus, each = nBlocks), - sd = abs(rep(taus, each = nBlocks)) * 0.5 - ), - nrow = nBlocks, - ncol = n_cats - ) - colnames(blocks) <- all_cats - vroom::vroom_write( - as.data.frame(blocks), - paste0(prefix, ".part_delete"), - delim = "\t" - ) - invisible(NULL) -} - -# Build a complete fixture directory for the full pipeline -.makeSldscFixtures <- function(envir = parent.frame()) { - base_dir <- withr::local_tempdir(.local_envir = envir) - - anno_dir <- file.path(base_dir, "annot") - frq_dir <- file.path(base_dir, "frq") - out_dir <- file.path(base_dir, "output") - dir.create(anno_dir) - dir.create(frq_dir) - dir.create(out_dir) - - plink_name <- "ref_chr" - - # Annotation + freq files for 2 chromosomes - for (chr in 1:2) { - .makeAnnotGz(anno_dir, chr) - .make_frq(frq_dir, chr, plinkName = plink_name) - } - - targets <- c("annot_A", "annot_B") - - # Single-target runs: 2 targets x 2 traits - for (trait in c("traitX", "traitY")) { - for (i in seq_along(targets)) { - pref <- file.path( - out_dir, - sprintf("%s_single_%s", trait, targets[i]) - ) - .makePolyfunSingle( - out_dir, - pref, - targets[i], - h2g = 0.3 + (i - 1) * 0.05 - ) - } - } - - # Joint runs: 1 per trait - for (trait in c("traitX", "traitY")) { - pref <- file.path(out_dir, sprintf("%s_joint", trait)) - .makePolyfunJoint(out_dir, pref, targets, h2g = 0.3) - } - - list( - base_dir = base_dir, - anno_dir = anno_dir, - frq_dir = frq_dir, - out_dir = out_dir, - plinkName = plink_name, - targets = targets, - trait_names = c("traitX", "traitY") - ) -} +# In-memory S-LDSC fixtures shared by test_SldscData.R, test_sldscWrapper.R +# and test_sldscPostprocessingPipeline.R. # ============================================================================= # In-memory builders for SldscData / compute / pipeline tests (no file I/O) diff --git a/tests/testthat/helper-vcf.R b/tests/testthat/helper-vcf.R index d3ddbb6b..1c8651fd 100644 --- a/tests/testthat/helper-vcf.R +++ b/tests/testthat/helper-vcf.R @@ -101,10 +101,6 @@ ) } -.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 = "") diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index cd2c097c..ae78338a 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -17,7 +17,7 @@ context("AllClasses (virtual base classes)") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -29,9 +29,9 @@ context("AllClasses (virtual base classes)") ) } -.alc_makeGr <- function(n = 3) { +.alc_makeGr <- function(n = 3, chrom = "chr1") { gr <- GenomicRanges::GRanges( - "chr1", + chrom, IRanges::IRanges( start = seq(100L, by = 100L, length.out = n), width = 1L @@ -47,13 +47,13 @@ context("AllClasses (virtual base classes)") gr } -.alc_makeGwasSumStats <- function(qcInfo = list()) { +.alc_makeGwasSumStats <- function(qcOptions = list()) { GwasSumStats( studyName = "g1", entry = list(.alc_makeGr()), genome = "hg19", ldReference = .alc_makeHandle(), - qcInfo = qcInfo + qcOptions = qcOptions ) } @@ -75,7 +75,7 @@ context("AllClasses (virtual base classes)") posterior_sd = rep(0.02, n), stringsAsFactors = FALSE ) - fineMappingRow( + FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl @@ -86,78 +86,249 @@ context("AllClasses (virtual base classes)") # SumStatsBase: studyName (inherited by QtlSumStats / GwasSumStats) # =========================================================================== -test_that("SumStatsBase: studyName on a GwasSumStats returns unique study names", { - ss <- .alc_makeGwasSumStats() - expect_equal(studyName(ss), "g1") +test_that("SumStatsBase: studyName on a GwasSumStats names each study once", { + # g1's variants span two chromosomes, so it is split into two rows and + # the study column repeats it; studyName() names each study once. + ss <- GwasSumStats( + studyName = c("g1", "g2"), + entry = list( + .alc_makeGr(chrom = c("chr1", "chr1", "chr2")), + .alc_makeGr() + ), + genome = "hg19", + ldReference = .alc_makeHandle() + ) + expect_identical(ss$study, c("g1", "g1", "g2")) + expect_identical(studyName(ss), c("g1", "g2")) }) # =========================================================================== # SumStatsBase: qcDiagnostics — every branch # =========================================================================== -test_that("SumStatsBase: qcDiagnostics returns NULL on empty qcInfo", { - ss <- .alc_makeGwasSumStats() # qcInfo = list() by default +test_that("SumStatsBase: qcDiagnostics returns NULL without per-row audits", { + # QC options recorded but no qcAudit column -> nothing to return. + ss <- .alc_makeGwasSumStats(qcOptions = list(step1 = "ok")) expect_null(qcDiagnostics(ss)) }) -test_that("SumStatsBase: qcDiagnostics returns NULL when entryAudit slot is absent", { - # qcInfo has steps but no entryAudit -> nothing to return. - ss <- .alc_makeGwasSumStats(qcInfo = list(step1 = "ok")) - expect_null(qcDiagnostics(ss)) +# A two-study GwasSumStats carrying one QC audit per row. +.alc_twoStudyQc <- function(audits) { + x <- GwasSumStats( + studyName = c("g1", "g2"), + entry = list(.alc_makeGr(), .alc_makeGr()), + genome = "hg19", + ldReference = .alc_makeHandle(), + qcOptions = list(step1 = "ok") + ) + x$qcAudit <- S4Vectors::SimpleList(audits) + x +} + +.alc_diagQc <- function(...) { + list(...) +} + +test_that("SumStatsBase: qcDiagnostics returns the selected study's table", { + diag1 <- data.frame(SNP = "rs1", outlier = FALSE) + diag2 <- data.frame(SNP = "rs2", outlier = TRUE) + ss <- .alc_twoStudyQc(.alc_diagQc( + list(ldMismatchDiagnostics = diag1), + list(ldMismatchDiagnostics = diag2) + )) + out <- qcDiagnostics(ss, studyName = "g2") + expect_s4_class(out, "DataFrame") + expect_equal(as.data.frame(out), diag2) + expect_equal(as.data.frame(qcDiagnostics(ss, studyName = "g1")), diag1) + # Two studies and no selector: which one is meant cannot be known. + expect_error(qcDiagnostics(ss), "2 studies") +}) + +test_that("SumStatsBase: qcDiagnostics is NULL for a selection without one", { + ss <- .alc_twoStudyQc(.alc_diagQc( + list(ldMismatchDiagnostics = data.frame(SNP = "rs1")), + list(other = "no diagnostics here") + )) + expect_null(qcDiagnostics(ss, studyName = "g2")) }) -test_that("SumStatsBase: qcDiagnostics returns the per-entry diagnostics by index", { - diag1 <- data.frame(SNP = "rs1", outlier = FALSE, stringsAsFactors = FALSE) - diag2 <- data.frame(SNP = "rs2", outlier = TRUE, stringsAsFactors = FALSE) - qc <- list( - entryAudit = list( - list(ldMismatchDiagnostics = diag1), - list(ldMismatchDiagnostics = diag2) +test_that("SumStatsBase: qcDiagnostics stacks a split study's rows", { + data(gwasSumStatsS4Example) + g <- gwasSumStatsS4Example + split <- GwasSumStats( + studyName = "trait1", + entry = list(sumStats(g)), + genome = "hg19", + ldReference = ldReference(g)[[1L]], + qcOptions = list(step1 = "ok"), + region = GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(1L, 15680321L), c(15680320L, 51304566L)) ) ) - ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_identical(qcDiagnostics(ss, entry = 1L), diag1) - expect_identical(qcDiagnostics(ss, entry = 2L), diag2) + split$qcAudit <- S4Vectors::SimpleList(.alc_diagQc( + list(ldMismatchDiagnostics = data.frame(SNP = "rs1")), + list(ldMismatchDiagnostics = data.frame(SNP = c("rs2", "rs3"))) + )) + expect_equal(nrow(split), 2L) + expect_equal(qcDiagnostics(split)$SNP, c("rs1", "rs2", "rs3")) +}) + +test_that("subsetting keeps each element's QC audit with it", { + # Each row's audit is a column of mcols(), so it subsets with the row: a + # subset never reports another element's diagnostics. + diag2 <- data.frame(SNP = "rs2", outlier = TRUE) + ss <- .alc_twoStudyQc(.alc_diagQc( + list(ldMismatchDiagnostics = data.frame(SNP = "rs1")), + list(ldMismatchDiagnostics = diag2) + )) + expect_equal(as.data.frame(qcDiagnostics(ss[2])), diag2) + expect_length(ss[2]$qcAudit, 1L) + expect_equal(as.data.frame(qcDiagnostics(ss[c(FALSE, TRUE)])), diag2) + expect_equal(as.data.frame(qcDiagnostics(ss[-1])), diag2) + # A collection without an audit subsets as before. + expect_null(.alc_makeGwasSumStats()[1]$qcAudit) +}) + +# =========================================================================== +# SumStatsBase: qcInfo / qcOptions, and the saved-object migration +# =========================================================================== + +test_that("qcInfo() is one row per tuple: its identity, then each count", { + ss <- .alc_twoStudyQc(.alc_diagQc( + list( + variantsIn = 10L, + contentFilters = list(nDropped = 2L), + ldMismatchDiagnostics = data.frame(SNP = "rs1") + ), + list(variantsIn = 8L) + )) + info <- qcInfo(ss) + expect_s4_class(info, "DataFrame") + expect_equal(info$study, c("g1", "g2")) + expect_equal(info$variantsIn, c(10L, 8L)) + # A nested count is named by its path; a row the step skipped is NA. + expect_equal(info$contentFilters.nDropped, c(2L, NA)) + # A per-variant table is qcDiagnostics()'s, never a column here. + expect_false(is_in("ldMismatchDiagnostics", colnames(info))) }) -test_that("SumStatsBase: qcDiagnostics(entry = NULL) returns the populated entries only", { - diag1 <- data.frame(SNP = "rs1", outlier = FALSE, stringsAsFactors = FALSE) - # Entry 2's audit has no ldMismatchDiagnostics field; should be filtered. - qc <- list( - entryAudit = list( - list(ldMismatchDiagnostics = diag1), - list(other = "no diagnostics here") +test_that("qcInfo() before QC names the rows and records nothing", { + info <- qcInfo(.alc_makeGwasSumStats()) + expect_equal(nrow(info), 1L) + expect_equal(colnames(info), c("study", "blockId")) +}) + +test_that("an audit that is not a list contributes no counts", { + expect_equal(pecotmr:::.qcAuditScalars(NULL), list()) + expect_equal(pecotmr:::.qcAuditScalars(list()), list()) + expect_equal(pecotmr:::.qcAuditScalars(data.frame(a = 1)), list()) + # Only scalars are counts: a vector is left out. + expect_equal( + pecotmr:::.qcAuditScalars(list(a = 1L, b = 1:3)), + list(a = 1L) + ) +}) + +test_that("qcOptions() returns the settings, separate from the audits", { + ss <- .alc_makeGwasSumStats(qcOptions = list(step1 = "ok")) + expect_equal(qcOptions(ss), list(step1 = "ok")) + expect_equal(qcOptions(.alc_makeGwasSumStats()), list()) +}) + +test_that(".rowQcAudit reads one row's audit, NULL where there is none", { + ss <- .alc_twoStudyQc(.alc_diagQc(list(a = 1), list(a = 2))) + expect_equal(pecotmr:::.rowQcAudit(ss, 2L), list(a = 2)) + expect_null(pecotmr:::.rowQcAudit(ss, 3L)) + expect_null(pecotmr:::.rowQcAudit(.alc_makeGwasSumStats(), 1L)) +}) + +# `x` as it was saved before the per-row audits moved into mcols(): the +# whole QC record in a `qcInfo` slot, and no `qcOptions` slot. +.alc_savedWithQcInfo <- function(x, qcInfo) { + attr(x, "qcOptions") <- NULL + attr(x, "qcInfo") <- qcInfo + x +} + +test_that("updateObject() splits a saved QC record into options and audits", { + ss <- .alc_twoStudyQc(.alc_diagQc(list(), list())) + ss$qcAudit <- NULL + saved <- .alc_savedWithQcInfo( + ss, + list( + step1 = "ok", + entryAudit = list(list(variantsIn = 3L), list(variantsIn = 4L)) ) ) - ss <- .alc_makeGwasSumStats(qcInfo = qc) - out <- qcDiagnostics(ss, entry = NULL) - expect_type(out, "list") - expect_equal(length(out), 1L) - expect_named(out, "1") - expect_identical(out[["1"]], diag1) + up <- updateObject(saved) + expect_true(validObject(up)) + expect_null(attr(up, "qcInfo", exact = TRUE)) + expect_equal(qcOptions(up), list(step1 = "ok")) + expect_equal(qcInfo(up)$variantsIn, c(3L, 4L)) }) -test_that("SumStatsBase: qcDiagnostics(entry = NULL) returns NULL when no entry has diagnostics", { - qc <- list(entryAudit = list(list(other = 1), list(other = 2))) - ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_null(qcDiagnostics(ss, entry = NULL)) +test_that("updateObject() keeps the options of a record with no audits", { + ss <- .alc_makeGwasSumStats() + up <- updateObject(.alc_savedWithQcInfo(ss, list(step1 = "ok"))) + expect_equal(qcOptions(up), list(step1 = "ok")) + expect_null(up$qcAudit) }) -test_that("SumStatsBase: qcDiagnostics errors on out-of-range entry", { - qc <- list( - entryAudit = list(list(ldMismatchDiagnostics = data.frame(z = 1))) +test_that("updateObject() drops audits it cannot match to rows, saying so", { + ss <- .alc_twoStudyQc(.alc_diagQc(list(), list())) + ss$qcAudit <- NULL + saved <- .alc_savedWithQcInfo( + ss, + list( + step1 = "ok", + entryAudit = list(list(variantsIn = 3L)) + ) ) - ss <- .alc_makeGwasSumStats(qcInfo = qc) - expect_error(qcDiagnostics(ss, entry = 0L), "must be a single integer") - expect_error(qcDiagnostics(ss, entry = 99L), "must be a single integer") - expect_error( - qcDiagnostics(ss, entry = c(1L, 2L)), - "must be a single integer" + expect_warning( + up <- updateObject(saved), + "1 row audit\\(s\\) for 2 row\\(s\\)" ) - expect_error( - qcDiagnostics(ss, entry = "first"), - "must be a single integer" + expect_equal(qcOptions(up), list(step1 = "ok")) + expect_null(up$qcAudit) +}) + +test_that("updateObject() makes every update old summary statistics need", { + # Saved as the oldest versions saved them: the QC record in `qcInfo`, the + # reference in `ldSketch`, and no element names. Each update on its own + # leaves an invalid object, so the one call has to make all of them. + ss <- .alc_makeGwasSumStats() + panel <- ldReference(ss)[["ld1"]] + saved <- .savedWithLdSketch( + .alc_savedWithQcInfo(`names<-`(ss, NULL), list(step1 = "ok")), + panel ) + up <- updateObject(saved) + expect_true(validObject(up)) + expect_equal(qcOptions(up), list(step1 = "ok")) + expect_identical(ldReference(up), list(ld1 = panel)) + expect_identical(names(up), names(ss)) + expect_identical(updateObject(up), up) +}) + +test_that("updateObject() moves a saved genome slot into seqinfo()", { + ss <- .alc_makeGwasSumStats() + saved <- ss + GenomeInfoDb::genome(saved) <- NA + attr(saved, "genome") <- "hg19" + up <- updateObject(saved) + expect_true(validObject(up)) + expect_null(attr(up, "genome", exact = TRUE)) + expect_identical(unique(unname(GenomeInfoDb::genome(up))), "hg19") + expect_identical(updateObject(up), up) +}) + +test_that("updateObject() leaves a current summary-statistics object as is", { + ss <- .alc_makeGwasSumStats(qcOptions = list(step1 = "ok")) + up <- updateObject(ss, verbose = FALSE) + expect_equal(qcOptions(up), list(step1 = "ok")) + expect_equal(as.list(up), as.list(ss)) + expect_message(updateObject(ss, verbose = TRUE), "updateObject") }) # =========================================================================== @@ -193,47 +364,115 @@ test_that("FineMappingResultBase: adjustPips on a zero-row collection returns th ) } -test_that("topLoci(): a pinned single entry returns a GRanges", { - fmr <- .alc_makeFmr2() - gr <- topLoci( - fmr, - studyName = "Q1", +test_that("topLoci() has no type switch: the stored table stays internal", { + # `raw = TRUE` once returned the stored table, a data.frame, from the same + # accessor that otherwise returns ranges. + expect_error(topLoci(.alc_makeFmr2(), raw = TRUE), "unused argument") +}) + +test_that("QtlFineMappingResult: topLoci aggregates entries when selectors do not pin one", { + # Two entries, no selectors: the old behaviour errored ("2 entries; pass + # study/context/trait/method"). Now it stacks the per-variant tables, + # prefixed with the row identity so variants stay attributable. + e1 <- .sc_makeFineMappingRow(3) + e2 <- .sc_makeFineMappingRow(2) + res <- QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + method = c("susie", "susie"), + entry = list(e1, e2) + ) + agg <- topLoci(res, signalCutoff = 0) + expect_s4_class(agg, "GRanges") + expect_equal(length(agg), 5L) + expect_true(all( + c("study", "context", "trait", "blockId", "method") %in% + names(S4Vectors::mcols(agg)) + )) + expect_equal(agg$context, c("c1", "c1", "c1", "c2", "c2")) + expect_true("variant_id" %in% names(S4Vectors::mcols(agg))) + # QTL results key on context/trait, so blockId is NA-filled. + expect_true(all(is.na(agg$blockId))) + # the added per-variant `method` must not duplicate the identity column + expect_equal(sum(names(S4Vectors::mcols(agg)) == "method"), 1L) +}) + +test_that("QtlFineMappingResult: topLoci with a full tuple keeps the bare (id-free) table", { + e1 <- .sc_makeFineMappingRow(3) + e2 <- .sc_makeFineMappingRow(2) + res <- QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + method = c("susie", "susie"), + entry = list(e1, e2) + ) + tl <- topLoci( + res, + studyName = "s1", context = "c1", trait = "t1", - method = "susie" + method = "susie", + signalCutoff = 0 ) - expect_s4_class(gr, "GRanges") + expect_s4_class(tl, "GRanges") + expect_equal(length(tl), 3L) + # single-entry fast path, unchanged + expect_false(is_in("context", names(S4Vectors::mcols(tl)))) }) -test_that("topLoci(): aggregating >1 entry also returns a GRanges", { - # Converting to ranges after stacking is what makes this work: the - # row-identity columns become mcols. The old type = "GRanges" branch had - # to refuse anything but a single pinned entry. - gr <- topLoci(.alc_makeFmr2()) - expect_s4_class(gr, "GRanges") - expect_true(all( - c("study", "context", "trait", "method") %in% - names(S4Vectors::mcols(gr)) - )) +test_that("QtlFineMappingResult: topLoci aggregates only the matching subset", { + e1 <- .sc_makeFineMappingRow(3) + e2 <- .sc_makeFineMappingRow(2) + res <- QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + method = c("susie", "susie"), + entry = list(e1, e2) + ) + sub <- topLoci(res, context = "c2", signalCutoff = 0) + expect_equal(length(sub), 2L) + expect_equal(unique(sub$context), "c2") }) -test_that("topLoci(raw = TRUE) stays a table", { - # The stored canonical table has no posterior projection to put on a - # range, so raw is the one form that is not a GRanges. - raw <- topLoci(.alc_makeFmr2(), raw = TRUE) - expect_true(is.data.frame(raw)) +test_that("QtlFineMappingResult: topLoci on a single-row collection still carries identity columns", { + # A no-selector call takes the aggregate path even for one row, so the PIP + # table has a uniform shape (identity columns present) whatever the row count + # -- callers don't special-case single-entry results. + row <- .sc_makeFineMappingRow(4) + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(row) + ) + tl <- topLoci(res, signalCutoff = 0) + expect_equal(length(tl), 4L) + # The row's own (projected) table, variant for variant. + expect_equal( + tl$variant_id, + .fmrRowTopLoci(row, signalCutoff = 0)$variant_id + ) + expect_true(all( + c("study", "context", "trait", "method", "variant_id") %in% + names(S4Vectors::mcols(tl)) + )) + expect_equal(unique(tl$context), "c1") }) -test_that("FineMappingResultBase aggregate view: empty per-entry views -> 0-row frame", { +test_that("aggregate view: empty per-entry views give empty ranges", { # .alc_makeFmEntry has no credible sets, so credibleSets aggregates to nothing. - expect_equal(nrow(credibleSets(.alc_makeFmr2())), 0L) + expect_length(credibleSets(.alc_makeFmr2()), 0L) }) test_that("FineMappingResultBase aggregate view: a no-match selector re-raises the selection error", { expect_error(credibleSets(.alc_makeFmr2(), studyName = "nope"), "entries") }) -test_that("FineMappingResultBase aggregate view: an empty collection yields a 0-row frame", { +test_that("aggregate view: an empty collection gives empty ranges", { empty <- QtlFineMappingResult( studyName = character(0), context = character(0), @@ -242,10 +481,9 @@ test_that("FineMappingResultBase aggregate view: an empty collection yields a 0- entry = list(), ldReference = .alc_makeHandle() ) - expect_equal(nrow(credibleSets(empty)), 0L) + expect_length(credibleSets(empty), 0L) }) - # =========================================================================== # Variant reconciliation: intersectVariants + retainedMass # =========================================================================== @@ -266,7 +504,7 @@ test_that("FineMappingResultBase aggregate view: an empty collection yields a 0- ) alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) - e <- fineMappingRow( + e <- FineMappingRow( vids, list( pip = pip, @@ -341,7 +579,7 @@ test_that("intersectVariants matches variants allele-aware", { expect_length(unlist(out$x, use.names = FALSE), 6L) }) -test_that("retainedMass reports per-effect surviving mass", { +test_that("retainedMass is each effect's pre-renormalization surviving mass", { x <- .rc_makeFmr(.rc_vids(1:40)) adj <- adjustPips(x, .rc_vids(1:20)) mass <- retainedMass(adj) @@ -352,17 +590,11 @@ test_that("retainedMass reports per-effect surviving mass", { expect_equal(unique(mass$nVariants), 20L) # Identity columns come along so the diagnostic is attributable. expect_true(all(c("study", "context", "trait", "method") %in% names(mass))) -}) -test_that("retainedMass is the PRE-renormalization share", { # After renormalization every effect row sums to 1, so the surviving share # is only knowable at adjustment time. A value of 1 across the board would # mean the diagnostic was reading the post-normalized alpha. - x <- .rc_makeFmr(.rc_vids(1:40)) - adj <- adjustPips(x, .rc_vids(1:20)) - mass <- retainedMass(adj) expect_false(all(abs(mass$retainedMass - 1) < 1e-9)) - fit <- susieFit(pecotmr:::.collectionEntry(adj, 1L)) expect_equal(rowSums(fit$alpha), rep(1, 3L), tolerance = 1e-10) }) @@ -389,7 +621,8 @@ test_that("retainedMass: empty result has the populated result's schema", { full <- retainedMass(both$x) expect_gt(nrow(full), 0L) expect_equal(colnames(empty), colnames(full)) - expect_equal(nrow(bind_rows(empty, full)), nrow(full)) + expect_s4_class(full, "DataFrame") + expect_equal(nrow(rbind(empty, full)), nrow(full)) }) test_that("retainedMass: identity columns follow the concrete class", { @@ -400,7 +633,6 @@ test_that("retainedMass: identity columns follow the concrete class", { expect_false(any(is_in(c("context", "trait"), cols))) }) - # --------------------------------------------------------------------------- # variantIds on SumStatsBase. # @@ -425,7 +657,10 @@ test_that("variantIds renders ids the same way the row classes do", { data(qtlSumStatsExample, envir = environment()) expect_equal( variantIds(qtlSumStatsExample), - as.data.frame(qtlSumStatsExample, require = "Z")$variant_id + pecotmr:::.entryToSumstatDf( + sumStats(qtlSumStatsExample), + require = "Z" + )$variant_id ) expect_match(variantIds(qtlSumStatsExample)[[1L]], "^chr[^:]+:\\d+:") }) @@ -449,7 +684,7 @@ test_that("variantIds defers the ambiguity error to the class", { data(qtlSumStatsMulticontextExample, envir = environment()) expect_error( variantIds(qtlSumStatsMulticontextExample), - "Pass `study`, `context`, and `trait`" + "Pass `studyName`, `context`, and `trait`" ) }) @@ -458,11 +693,150 @@ test_that("variantIds on an empty collection defers too", { expect_error(variantIds(qtlSumStatsExample[0]), "no rows") }) +# =========================================================================== +# Fit coverage: a row narrowed after its fit +# +# Narrowing a row's variants leaves its fit as it was made. Every reader of +# the fit says so, and nothing is rescaled. +# =========================================================================== + +# `x` with every row narrowed to its first `k` variants, its fits untouched. +.alc_narrowed <- function(x, k) { + endoapply(x, utils::head, k) +} + +test_that("a fine-mapping row keeps its fit's variants when narrowed", { + x <- .rc_makeFmr(.rc_vids(1:10)) + expect_equal(as.character(x$fitVariants[[1L]]), .rc_vids(1:10)) + narrowed <- .alc_narrowed(x, 4L) + expect_length(narrowed[[1L]], 4L) + expect_equal(as.character(narrowed$fitVariants[[1L]]), .rc_vids(1:10)) +}) + +test_that("reading a narrowed row's fit warns and returns it unchanged", { + x <- .rc_makeFmr(.rc_vids(1:10)) + narrowed <- .alc_narrowed(x, 4L) + expect_warning( + fit <- susieFit(narrowed), + "made with 10 variants, 6 of which this row no longer holds" + ) + expect_identical(fit, susieFit(x)) + expect_warning( + credibleSetSummary(narrowed), + "credibleSetSummary\\(\\): 1 row" + ) + # The rows that hold every variant of their fit read silently. + expect_no_warning(susieFit(x)) + expect_no_warning(lbf(x)) + expect_no_warning(credibleSetSummary(x)) +}) + +test_that("lbf() of a narrowed row keeps the held variants' values as fitted", { + x <- .rc_makeFmr(.rc_vids(1:10)) + expect_warning(out <- lbf(.alc_narrowed(x, 4L)), "lbf\\(\\): 1 row") + full <- lbf(x) + expect_equal(out$variant_id, .rc_vids(1:4)) + expect_equal( + as.data.frame(mcols(out)), + as.data.frame(mcols(full))[1:4, , drop = FALSE] + ) +}) + +test_that("the fSuSiE readers warn on a narrowed row too", { + data(fsusieFineMappingExample, envir = environment()) + narrowed <- .alc_narrowed(fsusieFineMappingExample, 3L) + expect_warning(fsusieCredibleBand(narrowed), "fsusieCredibleBand") + expect_warning(fsusieTraitEffects(narrowed), "fsusieTraitEffects") + expect_warning(fsusieAffectedRegions(narrowed), "fsusieAffectedRegions") +}) + +test_that("intersectVariants restricts a narrowed row's fit by id", { + # The route the coverage warning points to. The kept variants are found + # in the fit by id, so a row narrowed before reconciling restricts the + # fit's own columns rather than failing on the width mismatch. + x <- .rc_makeFmr(.rc_vids(1:30)) + y <- .rc_makeFmr(.rc_vids(5:50), studyName = "s2") + narrowed <- endoapply(x, utils::tail, 20L) + out <- intersectVariants(narrowed, y, oneSided = TRUE) + expect_no_warning(fit <- susieFit(out)) + expect_equal(colnames(fit$alpha), .rc_vids(11:30)) + kept <- susieFit(x)$alpha[, .rc_vids(11:30)] + expect_equal(unname(fit$alpha), unname(kept / rowSums(kept))) + expect_equal(as.character(out$fitVariants[[1L]]), .rc_vids(11:30)) +}) + +test_that("updateObject() backfills the variants each fit was made with", { + x <- .rc_makeFmr(.rc_vids(1:10)) + saved <- x + saved$fitVariants <- NULL + expect_equal( + as.character(updateObject(saved)$fitVariants[[1L]]), + .rc_vids(1:10) + ) + # A row narrowed before it was saved: its fit still names all ten. + savedNarrowed <- .alc_narrowed(x, 4L) + savedNarrowed$fitVariants <- NULL + up <- updateObject(savedNarrowed) + expect_equal(as.character(up$fitVariants[[1L]]), .rc_vids(1:10)) + expect_warning(susieFit(up), "no longer holds") + # A current collection is left as it is. + expect_identical(updateObject(x)$fitVariants, x$fitVariants) + expect_message(updateObject(x, verbose = TRUE), "updateObject") +}) + +test_that("updateObject() backfills fitVariants and keys LD rows in one call", { + x <- .rc_makeFmr(.rc_vids(1:10)) + saved <- x + saved$fitVariants <- NULL + up <- updateObject(.savedWithLdSketch(saved, NULL)) + expect_true(validObject(up)) + expect_equal(as.character(up$fitVariants[[1L]]), .rc_vids(1:10)) + expect_identical(ldReference(up), list()) + expect_true(is.na(up$ldReference)) + expect_identical(updateObject(up), up) +}) + +test_that("updateObject(): an unnamed fit records its row, no fit none", { + vids <- .rc_vids(1:3) + tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) + saved <- QtlFineMappingResult( + studyName = c("s1", "s2"), + context = c("c1", "c1"), + trait = c("g1", "g1"), + method = c("susie", "susie"), + entry = list( + FineMappingRow(vids, list(pip = c(0.5, 0.3, 0.2)), tl), + FineMappingRow(vids, NULL, tl) + ) + ) + saved$fitVariants <- NULL + up <- updateObject(saved) + expect_equal(as.character(up$fitVariants[[1L]]), vids) + expect_equal(as.character(up$fitVariants[[2L]]), character(0)) +}) + +test_that(".fitNamedVariants reads a fit's names, never susieR's null column", { + f <- pecotmr:::.fitNamedVariants + expect_equal(f(NULL), character(0)) + expect_equal(f(list()), character(0)) + # A null_weight fit: one more effect-matrix column, named "null". + alpha <- matrix(0.5, 1L, 3L, dimnames = list(NULL, c("v1", "v2", "null"))) + expect_equal(f(list(alpha = alpha)), c("v1", "v2")) + expect_equal( + f(list(pip = c(v1 = 0.1, v2 = 0.2), alpha = alpha)), + c("v1", "v2") + ) + lbfMat <- matrix(0, 1L, 2L, dimnames = list(NULL, c("a", "b"))) + expect_equal(f(list(lbf_variable = lbfMat)), c("a", "b")) + # fSuSiE names its variables on csd_X. + expect_equal(f(list(csd_X = c(x1 = 1, x2 = 2))), c("x1", "x2")) +}) + # =========================================================================== # adjustPips: entries that share no variant with `keepVariants` # # The zero-row short-circuit is covered above and the all-overlap path by -# test_ColocResult; the two partial/disjoint branches were not. +# test_fineMappingRow.R; these are the partial and disjoint branches. # =========================================================================== # Two entries built by .rc_makeFmr (which carries a real alpha matrix, as @@ -490,7 +864,7 @@ test_that("adjustPips refuses a keepVariants set disjoint from every entry", { }) test_that("adjustPips drops non-overlapping entries and says so", { - # Matches subsetRegion's rule: an element that trims to zero variants + # As with range subsetting: an element that trims to zero variants # goes away rather than lingering unadjusted. expect_message( out <- adjustPips(.ac_twoEntry(), .rc_vids(1:5)), @@ -500,16 +874,35 @@ test_that("adjustPips drops non-overlapping entries and says so", { expect_equal(as.character(mcols(out)$study), "s1") }) +test_that("adjustPips on a FineMappingResultBase collection renormalizes each entry", { + vidsA <- paste0("chr1:", 1:6, ":A:G") + vidsB <- paste0("chr1:", 3:8, ":A:G") + entryA <- .makeAdjustEntry(vidsA) + entryB <- .makeAdjustEntry(vidsB) + fmr <- QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c2"), + trait = c("g1", "g1"), + method = c("susie", "susie"), + entry = list(entryA, entryB) + ) + # Keep only variants shared by both entries' raw sets. + keep <- intersect(vidsA, vidsB) + adj <- adjustPips(fmr, keep) + expect_s4_class(adj, "QtlFineMappingResult") + expect_equal(nrow(adj), 2L) + expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 1L)), keep) + expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 2L)), keep) +}) # =========================================================================== -# .ssStitchElements()'s `ranges` filter +# .ssStitchElements()'s `window` filter # -# sumStats(x, ranges = ) is a documented argument that nothing exercised: -# every call left it NULL and returned through the early exit, so the -# chromosome test and the overlap intersection were both cold. +# The pipelines narrow a tuple to the span a pair's weights reach; the +# public sumStats() returns the whole tuple. # =========================================================================== -test_that("sumStats(ranges=) narrows the variants to the window", { +test_that(".ssStitchElements() narrows the variants to a window", { data(gwasSumStatsS4Example) full <- sumStats(gwasSumStatsS4Example) span <- range(GenomicRanges::start(full)) @@ -520,24 +913,23 @@ test_that("sumStats(ranges=) narrows the variants to the window", { span[[1L]] + (span[[2L]] - span[[1L]]) %/% 4L ) ) - sub <- sumStats(gwasSumStatsS4Example, ranges = win) + sub <- pecotmr:::.ssStitchElements(gwasSumStatsS4Example, 1L, win) expect_s4_class(sub, "GRanges") expect_lt(length(sub), length(full)) expect_gt(length(sub), 0L) expect_true(all(IRanges::overlapsAny(sub, win))) }) -test_that("sumStats(ranges=) on another chromosome returns nothing", { +test_that(".ssStitchElements() on another chromosome returns nothing", { # The chromosome test short-circuits before overlapsAny(), which would # otherwise warn about disjoint seqlevels. data(gwasSumStatsS4Example) off <- GenomicRanges::GRanges("chrZZ", IRanges::IRanges(1L, 100L)) - sub <- suppressWarnings(sumStats(gwasSumStatsS4Example, ranges = off)) + sub <- pecotmr:::.ssStitchElements(gwasSumStatsS4Example, 1L, off) expect_s4_class(sub, "GRanges") expect_equal(length(sub), 0L) }) - test_that("the genome check names a missing build and a mixed one", { f <- pecotmr:::.sumStatsCheckGenome gr <- GenomicRanges::GRanges( @@ -554,7 +946,6 @@ test_that("the genome check names a missing build and a mixed one", { expect_null(f(gr)) }) - test_that("an empty collection has no variants", { setClass( "RcEmptyKid", @@ -562,7 +953,7 @@ test_that("an empty collection has no variants", { representation( genome = "character", ldReference = "ANY", - qcInfo = "list" + qcOptions = "list" ) ) empty <- new( @@ -570,7 +961,7 @@ test_that("an empty collection has no variants", { GenomicRanges::GRangesList(), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) expect_equal(nrow(empty), 0L) expect_equal(pecotmr:::.rcAllVariants(empty), character(0)) @@ -585,11 +976,11 @@ test_that("retained mass is NULL for a fit that never went through reconciliatio }) # =========================================================================== -# Variant-level replacement: af<- / maf<- / nSamples<- dispatch on `value` +# Variant-level replacement: af<- / maf<- / sampleSize<- dispatch on `value` # =========================================================================== -# A replacement GRanges over the same variants as `x`, with the alleles in -# the given orientation and one payload column. +# A fillFromReference() reference over the same variants as `x`, with the +# alleles in the given orientation and one value column. .alc_replacementGr <- function(x, swap = FALSE, k = NULL, payload = 0.3) { ids <- variantIds(x) p <- parseVariantId(ids) @@ -623,7 +1014,7 @@ test_that("af<- numeric is positional and checks length hard", { expect_error(af(x) <- 0.3, "one value per variant") }) -test_that("maf<- and nSamples<- numeric are positional too", { +test_that("maf<- and sampleSize<- numeric are positional too", { data(qtlSumStatsExample) x <- qtlSumStatsExample n <- length(variantIds(x)) @@ -632,21 +1023,29 @@ test_that("maf<- and nSamples<- numeric are positional too", { maf(x) <- seq(0.05, 0.2, length.out = n) expect_equal(length(maf(x)), n) expect_equal(maf(x)[[1L]], 0.05) - nSamples(x) <- rep(1234, n) - expect_equal(unique(nSamples(x)), 1234) + sampleSize(x) <- rep(1234, n) + expect_equal(unique(sampleSize(x)), 1234) expect_error(maf(x) <- c(0.1, 0.2), "one value per variant") - expect_error(nSamples(x) <- 1L, "one value per variant") + expect_error(sampleSize(x) <- 1L, "one value per variant") }) -test_that("a GRanges replacement warns about variants it could not place", { +test_that("maf returns NULL when MAF column is absent, vector when present", { + obj_no_maf <- .qtlMakeOne(with_maf = FALSE) + expect_null(maf(obj_no_maf)) + + obj_maf <- .qtlMakeOne(n = 4, with_maf = TRUE) + expect_equal(length(maf(obj_maf)), 4L) +}) + +test_that("fillFromReference warns about variants it could not place", { data(qtlSumStatsExample) x <- qtlSumStatsExample gr <- .alc_replacementGr(x, payload = 0.4) # Two variants shifted far enough to match nothing. Silently dropping - # them would hide a mis-joined replacement table, so it warns and says + # them would hide a mis-joined reference table, so it warns and says # how many were ignored. extra <- GenomicRanges::shift(gr[1:2], 10000000L) - expect_warning(af(x) <- c(gr, extra), "were ignored") + expect_warning(x <- fillFromReference(x, c(gr, extra)), "were ignored") expect_equal(unique(af(x)), 0.4) }) @@ -664,33 +1063,27 @@ test_that("the variant-level setters work on a GwasSumStats as well", { ) }) -test_that("af<- GRanges matches on (chrom, pos, A1, A2) regardless of order", { +test_that("fillFromReference matches on (chrom, pos, A1, A2) in any order", { data(qtlSumStatsExample) x <- qtlSumStatsExample gr <- .alc_replacementGr(x, payload = 0.25) - af(x) <- gr[rev(seq_along(gr))] + x <- fillFromReference(x, gr[rev(seq_along(gr))]) expect_equal(unique(af(x)), 0.25) }) -test_that("a flip complements af but leaves maf and nSamples alone", { +test_that("a flip complements AF but leaves MAF and N alone", { data(qtlSumStatsExample) x <- qtlSumStatsExample swapped <- .alc_replacementGr(x, swap = TRUE, payload = 0.3) - # An allele swap sends af -> 1 - af. maf is min(af, 1 - af) and nSamples - # is a count, so both are swap-invariant -- complementing them would - # corrupt them. - y <- x - af(y) <- swapped - expect_equal(unique(af(y)), 0.7) - z <- x - maf(z) <- swapped - expect_equal(unique(maf(z)), 0.3) - w <- x - nSamples(w) <- swapped - expect_equal(unique(nSamples(w)), 0.3) -}) - -test_that("af<- GRanges requires A1/A2 and exactly one payload column", { + # An allele swap sends af -> 1 - af. maf is min(af, 1 - af) and the + # sample size is a count, so both are swap-invariant -- complementing + # them would corrupt them. + expect_equal(unique(af(fillFromReference(x, swapped, "AF"))), 0.7) + expect_equal(unique(maf(fillFromReference(x, swapped, "MAF"))), 0.3) + expect_equal(unique(sampleSize(fillFromReference(x, swapped, "N"))), 0.3) +}) + +test_that("fillFromReference requires A1/A2 and says which column it read", { data(qtlSumStatsExample) x <- qtlSumStatsExample n <- length(variantIds(x)) @@ -702,18 +1095,35 @@ test_that("af<- GRanges requires A1/A2 and exactly one payload column", { S4Vectors::mcols(bare) <- S4Vectors::DataFrame(v = rep(0.3, n)) # Without A1/A2 a flip cannot be detected, so the value cannot be # oriented and the write is refused rather than guessed at. - expect_error(af(x) <- bare, "must carry A1 and A2") + expect_error(fillFromReference(x, bare), "must carry A1 and A2") + # Two value columns, neither named like the target: which one is meant + # cannot be known, so it is refused rather than guessed. two <- .alc_replacementGr(x) S4Vectors::mcols(two)$extra <- 1 - expect_error(af(x) <- two, "exactly one value column") + expect_error( + fillFromReference(x, two), + "has no `AF` column.*the one column besides A1/A2 \\(got 2: v, extra" + ) }) -test_that("af<- sets NA for entry variants the replacement omits", { +test_that("fillFromReference reads the column named like the target", { + data(qtlSumStatsExample) + x <- qtlSumStatsExample + # A panel carries several per-variant columns at once; the one named + # like the target is read, whatever else rides along. + panel <- .alc_replacementGr(x, payload = 0.1) + S4Vectors::mcols(panel)$AF <- 0.6 + S4Vectors::mcols(panel)$MAF <- 0.4 + expect_equal(unique(af(fillFromReference(x, panel, "AF"))), 0.6) + expect_equal(unique(maf(fillFromReference(x, panel, "MAF"))), 0.4) +}) + +test_that("fillFromReference sets NA for variants the reference omits", { data(qtlSumStatsExample) x <- qtlSumStatsExample n <- length(variantIds(x)) partial <- .alc_replacementGr(x, k = 5L, payload = 0.42) - expect_warning(af(x) <- partial, "were set NA") + expect_warning(x <- fillFromReference(x, partial), "were set NA") a <- af(x) # Unknown, not unchanged. expect_equal(sum(!is.na(a)), 5L) @@ -721,7 +1131,7 @@ test_that("af<- sets NA for entry variants the replacement omits", { expect_equal(unique(a[!is.na(a)]), 0.42) }) -test_that("af<- refuses a replacement that matches nothing", { +test_that("fillFromReference refuses a reference that matches nothing", { data(qtlSumStatsExample) x <- qtlSumStatsExample far <- GenomicRanges::GRanges( @@ -733,5 +1143,343 @@ test_that("af<- refuses a replacement that matches nothing", { A2 = rep("G", 3), v = c(0.1, 0.2, 0.3) ) - expect_error(af(x) <- far, "no variant in the replacement matches") + expect_error(fillFromReference(x, far), "no variant in `reference` matches") +}) + +test_that("fillFromReference checks what it is handed", { + data(qtlSumStatsExample) + data(gwasSumStatsS4Example) + gr <- .alc_replacementGr(qtlSumStatsExample) + expect_error(fillFromReference(sumStats(qtlSumStatsExample), gr), "x") + expect_error( + fillFromReference(qtlSumStatsExample, as.data.frame(gr)), + "reference" + ) + expect_error( + fillFromReference(qtlSumStatsExample, gr, column = "BETA"), + "must be one of" + ) + # A GWAS collection is keyed by study alone, so a QTL selector is refused + # exactly as the positional setter refuses it. + expect_error( + fillFromReference(gwasSumStatsS4Example, gr, context = "brain"), + "context" + ) +}) + +# =========================================================================== +# A GWAS study split across rows: one study, several elements +# =========================================================================== + +# gwasSumStatsS4Example's one study split into two LD blocks of 100 variants. +.alc_blockSplit <- function() { + data(gwasSumStatsS4Example) + g <- gwasSumStatsS4Example + GwasSumStats( + studyName = "trait1", + entry = list(sumStats(g)), + genome = "hg19", + ldReference = ldReference(g)[[1L]], + qcOptions = qcOptions(g), + region = GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(1L, 15680321L), c(15680320L, 51304566L)) + ) + ) +} + +test_that("a positional setter writes across every row of a split study", { + x <- .alc_blockSplit() + expect_equal(nrow(x), 2L) + v <- seq(0.01, 0.5, length.out = 200L) + af(x, studyName = "trait1") <- v + expect_equal(nrow(x), 2L) + # sumStats() order is the rows' order, so each row takes its own piece. + expect_equal(af(x), v) + expect_equal(S4Vectors::mcols(x[[2L]])$AF, v[101:200]) + expect_error(af(x) <- v[-1L], "one value per variant \\(200") +}) + +test_that("fillFromReference places values across a split study's rows", { + x <- .alc_blockSplit() + gr <- sumStats(x) + rep <- gr + S4Vectors::mcols(rep) <- S4Vectors::DataFrame( + A1 = S4Vectors::mcols(gr)$A1, + A2 = S4Vectors::mcols(gr)$A2, + v = seq_len(200L) / 1000 + ) + # Every reference variant is in one row or the other, so neither the + # unused nor the missed warning fires. + expect_silent(x <- fillFromReference(x, rep[rev(seq_along(rep))], "MAF")) + expect_equal(maf(x), seq_len(200L) / 1000) + expect_silent(x <- fillFromReference(x, rep, "N")) + expect_equal(sampleSize(x)[c(1L, 200L)], c(0.001, 0.2)) +}) + +test_that("emptied rows of one study do not collide", { + x <- .alc_blockSplit() + # A PIP screen or filter() leaves each block an empty row; each keeps + # its own block, so two of them are not duplicates. + emptied <- combineGwasSumStats( + GwasSumStats( + studyName = "trait1", + entry = list(sumStats(x)[0L]), + genome = "hg19", + blockId = "b1" + ), + GwasSumStats( + studyName = "trait1", + entry = list(sumStats(x)[0L]), + genome = "hg19", + blockId = "b2" + ) + ) + expect_equal(unname(lengths(emptied)), c(0L, 0L)) + # The same block twice is still a duplicate. + expect_error( + combineGwasSumStats(emptied[1L], emptied[1L]), + "\\(study, range\\) must be unique" + ) + # Without a blockId, an empty row is keyed by its position; a non-empty + # one keeps its span key. + bare <- GenomicRanges::GRangesList( + GenomicRanges::GRanges(), + GenomicRanges::GRanges(), + GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 2L)) + ) + S4Vectors::mcols(bare) <- S4Vectors::DataFrame(study = rep("a", 3L)) + keys <- pecotmr:::.keyEmptyElements(bare, c("", "", "chr1:1-2")) + expect_false(anyDuplicated(keys) > 0L) + expect_identical(keys[[3L]], "chr1:1-2") +}) + +test_that("a show() line names one genome build however many chromosomes", { + gr <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 100L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c("chr1:100:A:G", "chr2:100:A:G"), + A1 = "A", + A2 = "G", + Z = c(1, 2), + N = 100L + ) + x <- GwasSumStats(studyName = "g1", entry = list(gr), genome = "hg38") + expect_identical(pecotmr:::.showGenomeBuild(x), "hg38") + expect_identical( + pecotmr:::.showGenomeBuild(GenomicRanges::GRangesList()), + "NA" + ) +}) + +test_that(".inputsBuild carries the one build the inputs name", { + hg19 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, width = 1L)) + GenomeInfoDb::genome(hg19) <- "hg19" + unset <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1L, width = 1L)) + f <- pecotmr:::.inputsBuild + expect_identical(f(list(hg19, unset, NULL), "f"), "hg19") + expect_identical(f(list(unset, NULL), "f"), NA_character_) + # A plain list is read element by element. + expect_identical(f(list(list(unset, hg19)), "f"), "hg19") + hg38 <- GenomeInfoDb::`genome<-`(unset, value = "hg38") + expect_error( + f(list(hg19, hg38), "colocPipeline"), + "colocPipeline: the inputs name different genome builds (hg19, hg38)", + fixed = TRUE + ) +}) + +test_that(".namedBuilds reads a QtlDataset's contexts, a MultiStudy's parts", { + tagged <- .sc_makeSe() + GenomeInfoDb::genome(tagged) <- "hg38" + qd <- QtlDataset( + studyName = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = tagged) + ) + expect_identical(pecotmr:::.namedBuilds(qd), "hg38") + ms <- MultiStudyQtlDataset( + qtlDatasets = list(s1 = qd), + sumStats = qtlSumStatsExample + ) + expect_setequal(pecotmr:::.namedBuilds(ms), c("hg38", "hg19")) + # An unranged experiment places nothing, so it names no build. + bare <- SummarizedExperiment::SummarizedExperiment(list(a = matrix(1))) + expect_identical(pecotmr:::.namedBuilds(bare), character(0)) +}) + +test_that(".oneBuild and .withGenome leave an unknown build unset", { + mixed <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(1L, width = 1L) + ) + GenomeInfoDb::genome(mixed) <- c("hg19", "hg38") + expect_identical(pecotmr:::.oneBuild(mixed), NA_character_) + expect_identical(pecotmr:::.withGenome(mixed, NA_character_), mixed) + expect_null(pecotmr:::.withGenome(NULL, "hg19")) + tagged <- pecotmr:::.withGenome(mixed, "hg19") + expect_identical(unname(GenomeInfoDb::genome(tagged)), c("hg19", "hg19")) +}) + +test_that("a result's ranged views carry its genome build", { + data(qtlFineMappingExample) + data(qtlFineMappingLbfExample) + x <- GenomeInfoDb::`genome<-`(qtlFineMappingExample, value = "hg19") + build <- function(gr) unique(unname(GenomeInfoDb::genome(gr))) + expect_identical(build(topLoci(x)), "hg19") + expect_identical(build(credibleSets(x)), "hg19") + expect_identical(build(marginalEffects(x)), "hg19") + expect_identical(build(lbf(qtlFineMappingLbfExample)), NA_character_) + expect_identical( + build(lbf(GenomeInfoDb::`genome<-`( + qtlFineMappingLbfExample, + value = "hg19" + ))), + "hg19" + ) +}) + +# =========================================================================== +# Collection aggregates: lbf, credibleSetSummary and the fSuSiE accessors +# =========================================================================== + +test_that("lbf aggregates over a collection, carrying identity + NA-filling ragged effects", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + mkEntry <- function(maxNumSingleEffects) { + lbf <- matrix( + seq_len(maxNumSingleEffects * length(vids)), + nrow = maxNumSingleEffects, + byrow = TRUE + ) # L x p + fit <- structure( + list(lbf_variable = lbf, pip = rep(0.3, length(vids))), + class = "susie" + ) + FineMappingRow( + variantIds = vids, + susieFit = fit, + topLoci = data.frame( + variant_id = vids, + pip = rep(0.3, length(vids)), + stringsAsFactors = FALSE + ) + ) + } + # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill of + # the ragged lbf_L columns described in the collection method's contract. + res <- QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("brain", "blood"), + trait = c("g", "g"), + method = c("susie", "susie"), + entry = list(mkEntry(2L), mkEntry(3L)) + ) + w <- lbf(res) + expect_s4_class(w, "GRanges") + expect_true(all( + c("study", "context", "trait", "method", "variant_id") %in% + names(S4Vectors::mcols(w)) + )) + expect_equal(length(w), 6L) # 2 entries x 3 variants + expect_setequal(unique(w$context), c("brain", "blood")) + expect_true("lbf_L3" %in% names(S4Vectors::mcols(w))) + expect_true(all(is.na(w$lbf_L3[w$context == "brain"]))) # L = 2 entry: no effect 3 + expect_true(all(!is.na(w$lbf_L3[w$context == "blood"]))) # L = 3 entry: present +}) + +test_that("credibleSetSummary aggregates across a collection with entry identity", { + mkEntry <- function() { + vn <- c("chr1:100:A:G", "chr1:200:C:T") + tl <- data.frame( + variant_id = vn, + pip = c(0.7, 0.2), + logBF = c(2.5, 0.3), + cs_95 = c("susie_1", "susie_1"), + cs_95_purity = c(0.9, 0.9), + stringsAsFactors = FALSE + ) + FineMappingRow(variantIds = vn, susieFit = list(x = 1), topLoci = tl) + } + res <- QtlFineMappingResult( + studyName = c("s", "s"), + context = c("brain", "blood"), + trait = c("g", "g"), + method = c("susie", "susie"), + entry = list(mkEntry(), mkEntry()) + ) + s <- credibleSetSummary(res) + expect_true(all( + c("study", "context", "trait", "method", "cs") %in% names(s) + )) + expect_equal(nrow(s), 2L) # one CS per entry + expect_setequal(unique(s$context), c("brain", "blood")) +}) + +test_that("fsusieCredibleBand on a result with no fSuSiE fit is empty ranges", { + data(qtlFineMappingExample, envir = environment()) + cb <- fsusieCredibleBand(qtlFineMappingExample) + expect_s4_class(cb, "GRanges") + expect_length(cb, 0L) +}) + +test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collection", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + fit <- .fsa_fits$none # one fit, read by both rows + res <- QtlFineMappingResult( + studyName = c("s", "s"), + context = c("brain", "blood"), + trait = c("g", "g"), + method = c("fsusie", "fsusie"), + entry = list(.fsa_entry(fit), .fsa_entry(fit)) + ) + + cb <- fsusieCredibleBand(res) + expect_true(all( + c( + "study", + "context", + "trait", + "method", + "cs", + "effect", + "lower", + "upper" + ) %in% + names(S4Vectors::mcols(cb)) + )) + expect_s4_class(cb, "GRanges") + expect_gt(length(cb), 0) + expect_setequal(unique(cb$context), c("brain", "blood")) + + gr <- fsusieAffectedRegions(res) + expect_s4_class(gr, "GRanges") + expect_gt(length(gr), 0) + expect_true(all( + c("study", "context", "trait", "cs", "purity", "direction") %in% + names(S4Vectors::mcols(gr)) + )) + expect_setequal(unique(S4Vectors::mcols(gr)$context), c("brain", "blood")) +}) + +test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an empty GRanges", { + e <- FineMappingRow( + variantIds = "chr1:100:A:G", + susieFit = list(pip = 0.5), + topLoci = data.frame( + variant_id = "chr1:100:A:G", + pip = 0.5, + stringsAsFactors = FALSE + ) + ) + res <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "t", + method = "susie", + entry = list(e) + ) + expect_equal(length(fsusieAffectedRegions(res)), 0L) }) diff --git a/tests/testthat/test_AllGenerics.R b/tests/testthat/test_AllGenerics.R index b1f937fd..eaaf71e1 100644 --- a/tests/testthat/test_AllGenerics.R +++ b/tests/testthat/test_AllGenerics.R @@ -16,14 +16,6 @@ ) } -# @noRd -.agIsGeneric <- function(nm) { - tryCatch( - methods::isGeneric(nm, where = asNamespace("pecotmr")), - error = function(e) FALSE - ) -} - test_that("every generic declared in AllGenerics.R has at least one method", { src <- readLines( system.file( @@ -51,18 +43,3 @@ test_that("every generic declared in AllGenerics.R has at least one method", { label = "generics with no method" ) }) - -test_that("exported generics are all reachable by name from the namespace", { - exported <- getNamespaceExports("pecotmr") - gens <- exported[map_lgl(exported, .agIsGeneric)] - expect_gt(length(gens), 50L) - # Every exported generic must resolve; a stale NAMESPACE entry pointing at - # a removed generic is the failure this catches. - for (g in gens) { - expect_true( - !is.null(getGenerics(asNamespace("pecotmr"))) && - exists(g, envir = asNamespace("pecotmr")), - label = str_c("exported generic '", g, "' resolves") - ) - } -}) diff --git a/tests/testthat/test_AnnotationMatrix.R b/tests/testthat/test_AnnotationMatrix.R index 3515d612..7e5ba75a 100644 --- a/tests/testthat/test_AnnotationMatrix.R +++ b/tests/testthat/test_AnnotationMatrix.R @@ -7,18 +7,27 @@ context("AnnotationMatrix") # The class is a RangedSummarizedExperiment, so the annotation matrix, # its per-column metadata and its ranges are read with assay(), # colData() and rowRanges() rather than through accessors of our own. -# Annotation *readers* stay in test_h2Annotations.R. Fixtures come from -# helper-h2Classes.R. - -test_that("AnnotationMatrix validates dimensions and meta", { - gr <- makeTestGRanges(10) - meta <- makeTestAnnotationMeta() - mat <- matrix(0, nrow = 10, ncol = 3) +# Annotation *readers* stay in test_h2Annotations.R. The fixtures are the +# two builders below. + +makeTestGRanges <- function(n = 10) { + GenomicRanges::GRanges( + seqnames = rep("chr1", n), + ranges = IRanges::IRanges( + start = seq(1000, by = 100, length.out = n), + width = 1L + ) + ) +} - obj <- AnnotationMatrix(mat, gr, meta) - expect_s4_class(obj, "AnnotationMatrix") - expect_true(methods::validObject(obj)) -}) +makeTestAnnotationMeta <- function() { + data.frame( + name = c("base", "enhancer", "promoter"), + tier = c("baseline", "candidate", "candidate"), + type = c("binary", "binary", "continuous"), + stringsAsFactors = FALSE + ) +} test_that("AnnotationMatrix rejects row mismatch", { gr <- makeTestGRanges(10) @@ -28,15 +37,6 @@ test_that("AnnotationMatrix rejects row mismatch", { expect_error(AnnotationMatrix(mat, gr, meta), "rows.*must match") }) -test_that("AnnotationMatrix rejects column mismatch with meta", { - gr <- makeTestGRanges(10) - meta <- makeTestAnnotationMeta() # 3 annotations - mat <- matrix(0, nrow = 10, ncol = 2) # only 2 columns - - # Constructor errors when colnames assignment fails (dimnames mismatch) - expect_error(AnnotationMatrix(mat, gr, meta)) -}) - test_that("AnnotationMatrix rejects invalid tier values", { gr <- makeTestGRanges(10) meta <- data.frame( @@ -63,20 +63,7 @@ test_that("AnnotationMatrix rejects invalid type values", { expect_error(AnnotationMatrix(mat, gr, meta), "type.*binary.*continuous") }) -test_that("AnnotationMatrix() constructor creates object from matrix", { - n <- 10 - gr <- makeTestGRanges(n) - meta <- makeTestAnnotationMeta() - mat <- matrix(runif(n * 3), nrow = n, ncol = 3) - - obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") - expect_s4_class(obj, "AnnotationMatrix") - expect_equal(nrow(assay(obj, "annotations")), n) - expect_equal(ncol(assay(obj, "annotations")), 3) - expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") -}) - -test_that("AnnotationMatrix() sets column names from annotation_meta", { +test_that("AnnotationMatrix() sets column names from annotationMeta", { n <- 10 gr <- makeTestGRanges(n) meta <- makeTestAnnotationMeta() @@ -113,6 +100,8 @@ test_that("AnnotationMatrix accessors round-trip the stored slots", { mat <- matrix(runif(n * 3), nrow = n, ncol = 3) obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") + expect_s4_class(obj, "AnnotationMatrix") + expect_true(methods::validObject(obj)) expect_equal(dim(assay(obj, "annotations")), c(n, 3L)) # colData is a DFrame keyed by the annotation names, so the plain # fixture compares as data after dropping those rownames. @@ -157,8 +146,6 @@ test_that("testedAnnotations() subsets to candidate-tier only", { expect_true(all(SummarizedExperiment::colData(cand)$tier == "candidate")) }) -# show() smoke test, moved here from test_showMethods.R so the test -# tree mirrors R/. test_that("show(AnnotationMatrix) does not error", { am <- AnnotationMatrix( matrix(0, nrow = 10, ncol = 1), diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 2f125853..4368fc04 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -13,7 +13,7 @@ test_that("ColocBoostResult: one element per confidence set", { ) expect_s4_class(x, "ColocBoostResult") expect_equal(nrow(x), 1L) - expect_equal(lengths(x), 1L) + expect_equal(unname(lengths(x)), 1L) expect_true(x$isColocalized) }) @@ -150,7 +150,10 @@ test_that("ColocBoostResult: reachable by range, not just identity", { ) win <- GenomicRanges::GRanges("chr1", IRanges::IRanges(150, 250)) expect_equal(length(IRanges::subsetByOverlaps(x, win)), 1L) - expect_equal(sum(lengths(subsetRegion(x, win))), 1L) + expect_equal( + sum(lengths(endoapply(x, IRanges::subsetByOverlaps, ranges = win))), + 1L + ) }) test_that("colocBoostOutcomes: joins each outcome to its identity", { @@ -176,31 +179,21 @@ test_that("regionVcp spans the region, not just set members", { expect_equal(sum(lengths(x)), 1L) }) -test_that("as.data.frame returns the set-level view", { +test_that("colocPairs is the set-level view; as.data.frame is standard", { x <- ColocBoostResult( list(.cbr_fake()), "xqtl_coloc", outcomeInfo = .cbr_info() ) + sets <- colocPairs(x) + expect_s4_class(sets, "DataFrame") + expect_equal(sets$cosId, "cos1:y1_y2") + expect_equal(sets$outcomes, "t1; t2") + # as.data.frame() is the inherited GRangesList coercion: one row per + # (set, variant), placed by its range. df <- as.data.frame(x) - expect_s3_class(df, "data.frame") - expect_equal(df$cosId, "cos1:y1_y2") - expect_equal(df$outcomes, "t1; t2") -}) - -test_that("separate_gwas runs are keyed by gwasStudy", { - # The three analyses are not parallel: separate_gwas is a named list one - # level deeper, so without gwasStudy its sets would be indistinguishable. - raw <- list( - xqtl_coloc = NULL, - joint_gwas = NULL, - separate_gwas = list(G1 = .cbr_fake(), G2 = .cbr_fake()), - computing_time = list() - ) - x <- .cbToResultObject(raw, .cbr_info()) - expect_equal(nrow(x), 2L) - expect_equal(x$analysis, rep("separate_gwas", 2L)) - expect_setequal(x$gwasStudy, c("G1", "G2")) + expect_true(all(c("group", "seqnames", "start") %in% names(df))) + expect_equal(nrow(df), sum(lengths(x))) }) test_that(".cbrFocalOutcome maps the no-focal sentinel to NA", { @@ -321,7 +314,7 @@ test_that("show counts colocalized and outcome-only sets separately", { # Pooled variants, and the fallbacks for a result missing its summary tables # =========================================================================== -test_that("colocVariants(pooled = TRUE) collapses to one row per variant", { +test_that("colocPooledVariants collapses to one row per variant", { # Noisy-OR only: ColocBoost's sets are not per-block slices of one signal, # so there is no mutually-exclusive sum stage the way coloc has. x <- ColocBoostResult( @@ -330,10 +323,11 @@ test_that("colocVariants(pooled = TRUE) collapses to one row per variant", { outcomeInfo = .cbr_info() ) long <- colocVariants(x) - pooled <- colocVariants(x, pooled = TRUE) - expect_lte(nrow(pooled), nrow(long)) + pooled <- colocPooledVariants(x) + expect_lte(length(pooled), length(long)) + pooledCols <- as.data.frame(S4Vectors::mcols(pooled)) expect_equal( - anyDuplicated(pooled[, c("analysis", "variant_id")]), + anyDuplicated(pooledCols[, c("analysis", "variant_id")]), 0L ) expect_true(all(pooled$vcp >= 0 & pooled$vcp <= 1)) @@ -365,7 +359,7 @@ test_that(".cbrTopVariable is NA when the id is absent from the table", { expect_true(is.na(.cbrTopVariable(NULL, "cos1"))) }) -test_that("validity names missing identity and outcomeInfo columns", { +test_that("validity names a missing identity column", { x <- ColocBoostResult( list(.cbr_fake()), "xqtl_coloc", @@ -418,6 +412,9 @@ test_that("the views answer an empty collection with empty tables", { expect_equal(length(empty), 0L) expect_equal(nrow(.cbrLongVariants(empty)), 0L) expect_equal(nrow(colocBoostOutcomes(empty)), 0L) + expect_length(colocPooledVariants(empty), 0L) + expect_s4_class(colocBoostOutcomes(empty), "DataFrame") + expect_s4_class(colocPairs(colocboostResultExample), "DataFrame") }) test_that("outcome info defaults to the empty frame and is not joined", { @@ -443,6 +440,87 @@ test_that("validity names the outcomeInfo columns that are missing", { ) }) +# A small LdMatrix to stand in for one side's reference. +.cbr_ldm <- function(ids = c("chr1:100:C:T", "chr1:200:A:G")) { + LdMatrix(matrix(c(1, 0.2, 0.2, 1), 2, 2, dimnames = list(ids, ids))) +} + +test_that("ColocBoostResult keeps a named LD reference per side", { + refs <- list( + qtl = .cbr_ldm(), + gwas = .cbr_ldm(c("chr1:300:G:A", "chr1:400:T:C")) + ) + info <- mutate( + .cbr_info(), + dataForm = "sumstats", + ldReference = c("qtl", "gwas") + ) + x <- ColocBoostResult( + list(.cbr_fake()), + "joint_gwas", + outcomeInfo = info, + ldReference = refs + ) + expect_identical(ldReference(x), refs) + out <- colocBoostOutcomes(x) + expect_equal( + out$ldReference[match(c("t1", "t2"), out$outcome)], + c("qtl", "gwas") + ) +}) + +test_that("ColocBoostResult with no LD reference holds an empty list", { + # An outcomeInfo without the column gets it, NA throughout. + x <- ColocBoostResult( + list(.cbr_fake()), + "xqtl_coloc", + outcomeInfo = .cbr_info() + ) + expect_identical(ldReference(x), list()) + expect_true(all(is.na(colocBoostOutcomes(x)$ldReference))) +}) + +test_that("ColocBoostResult refuses a lone LD reference", { + # Its name is what outcomeInfo keys on, so it is not made up. + expect_error( + ColocBoostResult( + list(.cbr_fake()), + "xqtl_coloc", + outcomeInfo = .cbr_info(), + ldReference = .cbr_ldm() + ), + "named list of LD references" + ) +}) + +test_that("ColocBoostResult refuses an outcome keyed to a missing reference", { + info <- mutate(.cbr_info(), ldReference = c("qtl", "gwas")) + expect_error( + ColocBoostResult( + list(.cbr_fake()), + "joint_gwas", + outcomeInfo = info, + ldReference = list(qtl = .cbr_ldm()) + ), + "not in ldReference: gwas" + ) +}) + +test_that("validity wants uniquely named LD references", { + # The shared check every class with per-row references validates with. + problems <- function(refs) .ldRefDictProblems(refs, character(0)) + expect_match(problems(list(.cbr_ldm())), "unique, non-empty names") + expect_match( + problems(list(a = .cbr_ldm(), a = .cbr_ldm())), + "unique, non-empty names" + ) + expect_match( + problems(list(a = .cbr_ldm(), b = "panel")), + "not LD references: b" + ) + expect_null(problems(list(a = .cbr_ldm()))) +}) + test_that("the region vcp skips runs that cannot supply one", { # Two ways a run is unusable: no vcp at all, and a vcp whose names are # missing so the variants cannot be placed. @@ -457,3 +535,78 @@ test_that("the region vcp skips runs that cannot supply one", { expect_s4_class(gr, "GRanges") expect_equal(length(gr), 1L) }) + +test_that("updateObject keys an old result's sumstat outcomes to its ref", { + ref <- .cbr_ldm() + info <- mutate(.cbr_info(), dataForm = c("sumstats", "individual")) + x <- ColocBoostResult(list(.cbr_fake()), "joint_gwas", outcomeInfo = info) + # As an earlier version saved it: one reference, no outcome keys. + old <- `slot<-`(x, "ldReference", check = FALSE, value = ref) + old <- `slot<-`( + old, + "outcomeInfo", + value = select(info, -any_of("ldReference")) + ) + new <- updateObject(old) + expect_true(methods::validObject(new)) + expect_identical(ldReference(new), list(ld1 = ref)) + expect_identical(new@outcomeInfo$ldReference, c("ld1", NA)) + # Saved before the slot was renamed, the reference sits in `ldSketch`. + sketched <- .savedUnder(old, c(ldSketch = "ldReference")) + expect_identical(updateObject(sketched), new) + # A current result is left as it is. + expect_identical(updateObject(x), x) +}) + +# =========================================================================== +# computingTime(): one row per analysis that ran +# =========================================================================== + +test_that("computingTime() tabulates each analysis: its runs and seconds", { + timing <- list( + Analysis = list( + xqtl_coloc = as.difftime(90, units = "secs"), + joint_gwas = NULL, + separate_gwas = list( + total = as.difftime(2, units = "mins"), + n_studies = 3L + ) + ) + ) + x <- ColocBoostResult( + list(), + character(0), + outcomeInfo = .cbr_info(), + computingTime = timing + ) + tab <- computingTime(x) + expect_s4_class(tab, "DataFrame") + # An analysis that did not run is no row. + expect_equal(tab$analysis, c("xqtl_coloc", "separate_gwas")) + expect_equal(tab$nRuns, c(1L, 3L)) + expect_equal(tab$seconds, c(90, 120)) +}) + +test_that("computingTime() has no rows when nothing was timed", { + tab <- computingTime( + ColocBoostResult(list(), character(0), outcomeInfo = .cbr_info()) + ) + expect_equal(nrow(tab), 0L) + expect_equal(colnames(tab), c("analysis", "nRuns", "seconds")) +}) + +test_that("a timing as a bare number, or without a total, still reads", { + expect_equal(pecotmr:::.cbrTimingSeconds(12.5), 12.5) + expect_true(is.na(pecotmr:::.cbrTimingSeconds(list(n_studies = 2L)))) + expect_true(is.na(pecotmr:::.cbrTimingRuns(list(total = 3)))) +}) + +test_that("ColocBoostResult() keeps the caller's metadata", { + x <- ColocBoostResult( + list(), + character(0), + outcomeInfo = .cbr_info(), + metadata = list(run = "r1") + ) + expect_equal(S4Vectors::metadata(x), list(run = "r1")) +}) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index cd1919f4..91ff3885 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -55,10 +55,21 @@ test_that("ColocResult: stores one element per pair with its variants", { x <- ColocResult(.cr_pairs(), .cr_variants()) expect_s4_class(x, "ColocResult") expect_equal(nrow(x), 1L) - expect_equal(lengths(x), 3L) + expect_equal(unname(lengths(x)), 3L) expect_equal(x$PP.H4.abf, 0.6) }) +test_that("ColocResult: keeps each pair's LD reference", { + ids <- c("chr1:100:C:T", "chr1:200:A:G") + ldm <- LdMatrix(matrix(c(1, 0.2, 0.2, 1), 2, dimnames = list(ids, ids))) + x <- ColocResult(.cr_pairs(), .cr_variants(), ldReference = ldm) + expect_identical(ldReference(x), list(ld1 = ldm)) + expect_equal(x$ldReference, "ld1") + none <- ColocResult(.cr_pairs(), .cr_variants()) + expect_identical(ldReference(none), list()) + expect_true(is.na(none$ldReference)) +}) + test_that("ColocResult: rejects an element with no per-variant layer", { # The whole point of the class is that SNP.PP.H4 survives; an element # without it must not construct. @@ -96,14 +107,18 @@ test_that("ColocResult: variants keep their alleles, so ids round-trip", { test_that("ColocResult: is reachable by range, not just by identity", { x <- ColocResult(.cr_pairs(), .cr_variants()) win <- GenomicRanges::GRanges("chr1", IRanges::IRanges(150, 250)) - expect_equal(sum(lengths(subsetRegion(x, win))), 1L) + expect_equal( + sum(lengths(endoapply(x, IRanges::subsetByOverlaps, ranges = win))), + 1L + ) expect_equal(length(IRanges::subsetByOverlaps(x, win)), 1L) }) test_that("colocVariants: colocPp is the pair posterior times the variant", { x <- ColocResult(.cr_pairs(pp4 = 0.5), .cr_variants()) v <- colocVariants(x) - expect_equal(nrow(v), 3L) + expect_s4_class(v, "GRanges") + expect_equal(length(v), 3L) expect_equal(v$colocPp, 0.5 * c(0.6, 0.3, 0.1)) }) @@ -154,29 +169,41 @@ test_that("colocGenes: keeps distinct second-side traits apart", { expect_setequal(genes$gwasTrait, c("h1", "h2")) }) -test_that("colocVariants(pooled): pools by the same rule as genes", { +test_that("colocPooledVariants: pools by the same rule as genes", { pairs <- .cr_pairs( qtlCs = c(1L, 2L), blockId = c("b1", "b1"), pp4 = c(0.5, 0.25) ) x <- ColocResult(pairs, .cr_variants(2L)) - pooled <- colocVariants(x, pooled = TRUE) - expect_equal(nrow(pooled), 3L) + pooled <- colocPooledVariants(x) + expect_equal(length(pooled), 3L) lead <- pooled[pooled$variant_id == "chr1:100:A:G", ] expect_equal(lead$colocPp, 1 - (1 - 0.5 * 0.6) * (1 - 0.25 * 0.6)) }) test_that("colocCredibleSets: takes the smallest set reaching coverage", { x <- ColocResult(.cr_pairs(), .cr_variants()) - expect_equal(colocCredibleSets(x, coverage = 0.5)$csSize, 1L) - expect_equal(colocCredibleSets(x, coverage = 0.9)$csSize, 2L) - expect_equal(colocCredibleSets(x, coverage = 0.95)$csSize, 3L) + expect_equal(mcols(colocCredibleSets(x, coverage = 0.5))$csSize, 1L) + expect_equal(mcols(colocCredibleSets(x, coverage = 0.9))$csSize, 2L) + expect_equal(mcols(colocCredibleSets(x, coverage = 0.95))$csSize, 3L) }) -test_that("colocCredibleSets: reports the lead variant and coverage", { +test_that("colocCredibleSets: each set's members are its element", { x <- ColocResult(.cr_pairs(), .cr_variants()) cs <- colocCredibleSets(x, coverage = 0.9) + expect_s4_class(cs, "GRangesList") + expect_equal(unname(lengths(cs)), mcols(cs)$csSize) + expect_equal( + .grVariantIds(cs[[1L]]), + c("chr1:100:A:G", "chr1:200:C:T") + ) + expect_equal(mcols(cs[[1L]])$SNP.PP.H4, c(0.6, 0.3)) +}) + +test_that("colocCredibleSets: reports the lead variant and coverage", { + x <- ColocResult(.cr_pairs(), .cr_variants()) + cs <- mcols(colocCredibleSets(x, coverage = 0.9)) expect_equal(cs$leadVariant, "chr1:100:A:G") expect_equal(cs$leadPp, 0.6) expect_equal(cs$csCoverage, 0.9) @@ -185,17 +212,17 @@ test_that("colocCredibleSets: reports the lead variant and coverage", { test_that("colocCredibleSets: minPp4 drops pairs before any LD work", { pairs <- .cr_pairs(qtlCs = c(1L, 2L), pp4 = c(0.8, 0.1)) x <- ColocResult(pairs, .cr_variants(2L)) - expect_equal(nrow(colocCredibleSets(x)), 2L) - expect_equal(nrow(colocCredibleSets(x, minPp4 = 0.5)), 1L) - expect_equal(nrow(colocCredibleSets(x, minPp4 = 0.99)), 0L) + expect_length(colocCredibleSets(x), 2L) + expect_length(colocCredibleSets(x, minPp4 = 0.5), 1L) + expect_length(colocCredibleSets(x, minPp4 = 0.99), 0L) }) test_that("colocCredibleSets: requireMaxH4 keeps only H4-dominant pairs", { pairs <- .cr_pairs(qtlCs = c(1L, 2L), pp4 = c(0.8, 0.1)) x <- ColocResult(pairs, .cr_variants(2L)) cs <- colocCredibleSets(x, requireMaxH4 = TRUE) - expect_equal(nrow(cs), 1L) - expect_equal(cs$qtlCs, 1L) + expect_length(cs, 1L) + expect_equal(mcols(cs)$qtlCs, 1L) }) test_that("colocCredibleSets: purity is NA, not passing, without LD", { @@ -204,16 +231,27 @@ test_that("colocCredibleSets: purity is NA, not passing, without LD", { # to be attached. x <- ColocResult(.cr_pairs(), .cr_variants()) cs <- colocCredibleSets(x) - expect_true(is.na(cs$purity)) - expect_equal(nrow(colocCredibleSets(x, minAbsCorr = 0.99)), 1L) + expect_true(is.na(mcols(cs)$purity)) + expect_length(colocCredibleSets(x, minAbsCorr = 0.99), 1L) +}) + +test_that("colocCredibleSets: carries the result's genome", { + x <- ColocResult(.cr_pairs(), .cr_variants()) + GenomeInfoDb::genome(x) <- "hg38" + cs <- colocCredibleSets(x) + expect_equal(unique(unname(GenomeInfoDb::genome(cs))), "hg38") }) -test_that("as.data.frame returns the pair view", { +test_that("colocPairs is the pair view; as.data.frame is standard", { x <- ColocResult(.cr_pairs(), .cr_variants()) + pairs <- colocPairs(x) + expect_equal(nrow(pairs), 1L) + expect_equal(pairs$PP.H4.abf, 0.6) + # as.data.frame() is the inherited GRangesList coercion: one row per + # (pair, variant), placed by its range. df <- as.data.frame(x) - expect_s3_class(df, "data.frame") - expect_equal(nrow(df), 1L) - expect_equal(df$PP.H4.abf, 0.6) + expect_true(all(c("group", "seqnames", "start") %in% names(df))) + expect_equal(nrow(df), sum(lengths(x))) }) test_that(".crPivotColocResults: maps results column K to summary row K", { @@ -298,14 +336,19 @@ test_that("show on an empty ColocResult stops after the header", { )[seq_len(n)] } +# The panel as a pair's LD reference, keyed the way a ColocResult keys it. +.cr_refs <- function() { + list(ld1 = .cr_panel()) +} + test_that("a singleton credible set is pure by definition", { # No pair to correlate; susie treats it as pure rather than unmeasurable. - expect_equal(.crPurityOne(.cr_panelIds(1L), .cr_panel()), 1) + expect_equal(.crPurityOne(.cr_panelIds(1L), "ld1", .cr_refs()), 1) }) test_that("purity is the minimum absolute correlation among members", { ids <- .cr_panelIds(3L) - pur <- .crPurityOne(ids, .cr_panel()) + pur <- .crPurityOne(ids, "ld1", .cr_refs()) R <- computeLd(.cr_panel(), snpIdx = 1:3) expect_equal(pur, min(abs(R[upper.tri(R)])), tolerance = 1e-8) }) @@ -314,29 +357,48 @@ test_that("purity is NA when the panel cannot supply the members", { # Reported honestly rather than defaulted to a passing value: an # unmeasurable purity must not look like a pure set. expect_true(is.na( - .crPurityOne(c("chr9:1:A:G", "chr9:2:C:T"), .cr_panel()) + .crPurityOne(c("chr9:1:A:G", "chr9:2:C:T"), "ld1", .cr_refs()) )) }) -test_that("purity is NA for every set when there is no LD reference", { - out <- tibble(csVariants = list(c("a", "b"), c("c", "d"))) - expect_equal(.crPuritiesFor(out, NULL), c(NA_real_, NA_real_)) +# One credible-set record as .crCredibleSets() builds it: the members' +# ranges and the pair row that names its LD reference. +.cr_set <- function(ids, ldReference) { + list( + members = .variantIdsToGRanges(ids, what = "variant_id"), + row = tibble(ldReference = ldReference) + ) +} + +test_that("purity is NA for every set whose pair has no LD reference", { + sets <- list( + .cr_set(c("chr1:100:A:G", "chr1:200:C:T"), NA_character_), + .cr_set("chr1:300:G:A", NA_character_) + ) + expect_equal( + map_dbl(sets, .crSetPurity, refs = list()), + c(NA_real_, NA_real_) + ) }) -test_that("purity is computed per set when an LD reference is supplied", { - # The counterpart of the NULL case above: with a panel in hand each set - # is mapped through .crPurityOne rather than short-circuiting to NA. +test_that("purity is computed per set against its own pair's reference", { + # The counterpart of the no-reference case above: each set is mapped + # through .crPurityOne with the reference its pair names. ids <- .cr_panelIds(3L) - out <- tibble(csVariants = list(ids, ids[[1L]])) - pur <- .crPuritiesFor(out, .cr_panel()) - expect_length(pur, 2L) - expect_false(anyNA(pur)) + sets <- list( + .cr_set(ids, "ld1"), + .cr_set(ids[[1L]], "ld1"), + .cr_set(ids, NA_character_) + ) + pur <- map_dbl(sets, .crSetPurity, refs = .cr_refs()) + expect_length(pur, 3L) expect_equal(pur[[2L]], 1) # singleton is pure by definition expect_equal( pur[[1L]], - .crPurityOne(ids, .cr_panel()), + .crPurityOne(ids, "ld1", .cr_refs()), tolerance = 1e-8 ) + expect_true(is.na(pur[[3L]])) }) # =========================================================================== @@ -386,6 +448,20 @@ test_that("the views answer an empty collection with empty tables", { expect_equal(nrow(.crLongVariants(empty)), 0L) expect_equal(.crPairFilter(empty, 0, FALSE), integer(0)) expect_equal(nrow(colocGenes(empty)), 0L) + expect_length(colocPooledVariants(empty), 0L) + expect_s4_class(colocPooledVariants(empty), "GRanges") +}) + +test_that("the tabular views are DataFrames, the ranged ones GRanges", { + x <- ColocResult(.cr_pairs(), .cr_variants()) + expect_s4_class(colocPairs(x), "DataFrame") + expect_s4_class(colocGenes(x), "DataFrame") + expect_s4_class(colocCredibleSets(x, coverage = 0.5), "GRangesList") + expect_s4_class(mcols(colocCredibleSets(x, coverage = 0.5)), "DataFrame") + expect_s4_class(colocVariants(x), "GRanges") + expect_s4_class(colocPooledVariants(x), "GRanges") + # Column names survive the conversion as written. + expect_true("PP.H4.abf" %in% colnames(colocPairs(x))) }) test_that("pivoting a per-row column that is absent yields the empty frame", { @@ -394,9 +470,13 @@ test_that("pivoting a per-row column that is absent yields the empty frame", { }) test_that("a NULL purity cutoff leaves the credible sets untouched", { - # NULL means "do not filter", which is different from filtering at 0. - out <- tibble(a = 1, purity = NA_real_) - expect_identical(.crApplyPurityFilter(out, NULL), out) + # NULL means "do not filter": a set a cutoff would drop stays. + ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + R <- matrix(0.2, 3L, 3L, dimnames = list(ids, ids)) + diag(R) <- 1 + x <- ColocResult(.cr_pairs(), .cr_variants(), ldReference = LdMatrix(R)) + expect_equal(mcols(colocCredibleSets(x, minAbsCorr = NULL))$purity, 0.2) + expect_length(colocCredibleSets(x, minAbsCorr = 0.8), 0L) }) test_that("a pair with no variants contributes no credible set", { @@ -409,6 +489,14 @@ test_that("a pair with no variants contributes no credible set", { cr <- ColocResult(.cr_pairs(), list(noVariants)) expect_equal(length(cr[[1L]]), 0L) expect_null(.crCsForPair(1L, cr, coverage = 0.95)) - # ...and the accessor over that result is an empty table, not an error. - expect_equal(nrow(colocCredibleSets(cr)), 0L) + # ...and the accessor over that result is an empty list, not an error. + expect_length(colocCredibleSets(cr), 0L) + expect_s4_class(colocCredibleSets(cr), "GRangesList") +}) + +test_that("ColocResult() keeps the caller's metadata", { + x <- ColocResult(.cr_pairs(), .cr_variants(), metadata = list(run = "r1")) + expect_equal(S4Vectors::metadata(x), list(run = "r1")) + plain <- ColocResult(.cr_pairs(), .cr_variants()) + expect_equal(S4Vectors::metadata(plain), list()) }) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index 0d71d5ef..279311e9 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -4,16 +4,20 @@ context("CtwasResult") # test_CtwasResultEntry.R; this file covers the CtwasResult collection. .cr_entry <- function(ids = c("g1", "g2"), pip = c(0.9, 0.1), prior = NULL) { + # Ranged, as the pipeline stores them: each id placed at a position. + at <- IRanges::IRanges(100L * seq_along(ids), width = 1L) CtwasResultEntry( - posteriors = data.frame( + posteriors = GenomicRanges::GRanges( + "chr1", + at, id = ids, - susie_pip = pip, - stringsAsFactors = FALSE + susie_pip = pip ), - susieAlpha = data.frame( + susieAlpha = GenomicRanges::GRanges( + "chr1", + at, id = ids, - susie_alpha = pip, - stringsAsFactors = FALSE + susie_alpha = pip ), groupPriors = prior, regionInfo = data.frame(region_id = "r1", stringsAsFactors = FALSE) @@ -47,11 +51,12 @@ test_that("CtwasResult: ctwasPosteriors aggregates rows tagged with run identity ) ) fm <- ctwasPosteriors(cr) + expect_s4_class(fm, "GRanges") expect_true(all( c("gwasStudy", "study", "context", "method", "id", "susie_pip") %in% - names(fm) + names(S4Vectors::mcols(fm)) )) - expect_equal(nrow(fm), 3L) # 2 + 1 gene rows + expect_equal(length(fm), 3L) # 2 + 1 gene rows expect_equal(fm$context, c("brain", "brain", "liver")) }) @@ -67,10 +72,10 @@ test_that("CtwasResult: susieAlpha aggregates the per-effect table with identity ) ) sa <- susieAlpha(cr) - expect_equal(nrow(sa), 3L) + expect_equal(length(sa), 3L) expect_true(all( c("gwasStudy", "study", "context", "method", "susie_alpha") %in% - names(sa) + names(S4Vectors::mcols(sa)) )) expect_equal(sa$context, c("brain", "brain", "liver")) }) @@ -140,7 +145,7 @@ test_that("CtwasResult: a joint column of the wrong length is rejected", { ) }) -test_that("CtwasResult: ctwasPosteriors/susieAlpha are NULL when empty or all-NULL", { +test_that("CtwasResult: the views are empty ranges when no row has a payload", { empty <- CtwasResult( gwasStudy = character(0), studyName = character(0), @@ -148,8 +153,8 @@ test_that("CtwasResult: ctwasPosteriors/susieAlpha are NULL when empty or all-NU method = character(0), entry = list() ) - expect_null(ctwasPosteriors(empty)) - expect_null(susieAlpha(empty)) + expect_length(ctwasPosteriors(empty), 0L) + expect_s4_class(susieAlpha(empty), "GRanges") nullE <- CtwasResult( gwasStudy = "D1", studyName = "Q1", @@ -157,8 +162,8 @@ test_that("CtwasResult: ctwasPosteriors/susieAlpha are NULL when empty or all-NU method = "susie", entry = list(CtwasResultEntry(posteriors = NULL, susieAlpha = NULL)) ) - expect_null(ctwasPosteriors(nullE)) - expect_null(susieAlpha(nullE)) + expect_length(ctwasPosteriors(nullE), 0L) + expect_length(susieAlpha(nullE), 0L) }) test_that("CtwasResult: show() prints a one-line-per-run summary", { @@ -176,9 +181,9 @@ test_that("CtwasResult: show() prints a one-line-per-run summary", { # =========================================================================== # Validity: the branches that name what is wrong # -# CtwasResult is a DFrame subclass, so its columns are ordinary DataFrame -# columns and a downstream edit can drop or retype one. Validity guards that, -# but every test above built a valid object. +# A CtwasResult's identity and payload columns are mcols, so a downstream edit +# can drop or retype one. Validity guards that, but every test above built a +# valid object. # =========================================================================== .ctr_res <- function() { @@ -200,32 +205,133 @@ test_that("validity names a missing required column", { ) }) -test_that("validity requires one entry payload per row", { - # Written straight into listData: `$<-` enforces the length itself, so - # the only way to reach this branch is the direct slot edit that a - # careless downstream mutation would perform. +test_that("a joint column must be character", { bad <- .ctr_res() - bad@listData$entry <- list(.cr_entry(), .cr_entry()) + S4Vectors::mcols(bad)$jointStudies <- 1L expect_error( methods::validObject(bad), - "length\\(entry\\) must equal nrow" + "'jointStudies' column must be character \\(got integer\\)" ) }) -test_that("a joint column must be character", { - bad <- .ctr_res() - bad@listData$jointStudies <- 1L + +test_that("a payload with no coordinates is refused at construction", { + # An entry built by hand from a plain table has nowhere to place its rows + # in a ranged collection, so the constructor says so instead of dropping + # them. + tableOnly <- CtwasResultEntry( + posteriors = data.frame(id = "g1", susie_pip = 0.5) + ) expect_error( - methods::validObject(bad), - "'jointStudies' column must be character \\(got integer\\)" + CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = "susie", + entry = list(tableOnly) + ), + "run 1's posteriors carry no genomic coordinates" ) + # The entry itself still reads back as given. + expect_s3_class(ctwasPosteriors(tableOnly), "data.frame") }) +# =========================================================================== +# One element per cTWAS region +# =========================================================================== + +# A run over two cTWAS regions on two chromosomes, with its region metadata. +.cr_twoRegionEntry <- function() { + regions <- c("chr1_1_1000", "chr2_1_1000") + pos <- GenomicRanges::GRanges( + c("chr1", "chr1", "chr2"), + IRanges::IRanges(c(100L, 200L, 300L), width = 1L), + id = c("g1", "g2", "g3"), + region_id = regions[c(1L, 1L, 2L)], + susie_pip = c(0.9, 0.1, 0.5) + ) + sa <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 300L), width = 1L), + id = c("g1", "g3"), + region_id = regions, + susie_alpha = c(0.8, 0.4) + ) + ri <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(1L, 999L), + region_id = regions + ) + CtwasResultEntry( + posteriors = pos, + susieAlpha = sa, + groupPriors = list(group_prior = c(gene = 0.01)), + regionInfo = ri + ) +} -test_that("an empty ranged payload flattens to NULL", { - expect_null(pecotmr:::.ctwasPayloadAsDf(GenomicRanges::GRanges())) - expect_null(pecotmr:::.ctwasPayloadAsDf(NULL)) - # A non-GRanges payload is passed straight through. - df <- data.frame(a = 1) - expect_equal(pecotmr:::.ctwasPayloadAsDf(df), df) +test_that("a run splits into one element per cTWAS region", { + cr <- CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = "susie", + entry = list(.cr_twoRegionEntry()) + ) + expect_s4_class(cr, "RangedTupleList") + expect_equal(length(cr), 2L) + expect_equal(cr$blockId, c("chr1_1_1000", "chr2_1_1000")) + expect_equal(unname(lengths(cr)), c(2L, 1L)) + # Each element sits on one chromosome, so the range machinery applies. + expect_equal(unname(lengths(range(cr))), c(1L, 1L)) + # The region's own payloads ride with it; the run's priors repeat. + expect_equal(cr$susieAlpha[[2L]]$id, "g3") + expect_equal(cr$regionInfo[[1L]]$region_id, "chr1_1_1000") + expect_identical(cr$groupPriors[[1L]], cr$groupPriors[[2L]]) + # Named by the run identity plus the region. + expect_equal(names(cr)[[1L]], "Q1|brain|susie|D1|chr1_1_1000") + # The stacked views put every region back together. + expect_equal(ctwasPosteriors(cr)$id, c("g1", "g2", "g3")) + expect_equal(susieAlpha(cr)$id, c("g1", "g3")) + # And a region narrows like any ranged collection. + one <- IRanges::subsetByOverlaps( + cr, + GenomicRanges::GRanges("chr2", IRanges::IRanges(1L, 1000L)) + ) + expect_equal(one$blockId, "chr2_1_1000") + expect_s4_class(one, "CtwasResult") +}) + +test_that("updateObject rebuilds a CtwasResult saved as a table of runs", { + # The earlier shape: a DFrame of whole runs, one entry per row. + old <- S4Vectors::DataFrame( + gwasStudy = "D1", + study = "Q1", + context = "brain", + method = "susie", + entry = S4Vectors::SimpleList(list(.cr_twoRegionEntry())) + ) + attr(old, "class") <- methods::getClass("CtwasResult")@className + up <- updateObject(old) + expect_s4_class(up, "CtwasResult") + expect_true(methods::validObject(up)) + expect_equal(length(up), 2L) + # A current object needs nothing. + expect_identical(updateObject(up), up) + expect_message( + updateObject(up, verbose = TRUE), + "updateObject\\(object = 'CtwasResult'\\)" + ) +}) + +test_that("CtwasResult() keeps the caller's metadata", { + cr <- CtwasResult( + gwasStudy = "D1", + studyName = "Q1", + context = "brain", + method = "susie", + entry = list(.cr_entry()), + metadata = list(run = "r1") + ) + expect_equal(S4Vectors::metadata(cr), list(run = "r1")) }) diff --git a/tests/testthat/test_CtwasResultEntry.R b/tests/testthat/test_CtwasResultEntry.R index 8f7dcedc..e00eb53b 100644 --- a/tests/testthat/test_CtwasResultEntry.R +++ b/tests/testthat/test_CtwasResultEntry.R @@ -25,6 +25,19 @@ test_that("CtwasResultEntry: constructor + accessors round-trip", { expect_equal(ctwasGroupPriors(e)$group_prior, c(brain = 0.01)) }) +test_that("as(entry, 'GRanges') gives placed posteriors only", { + placed <- GenomicRanges::GRanges("chr1:100-200", susie_pip = 0.4) + expect_identical( + as(CtwasResultEntry(posteriors = placed), "GRanges"), + placed + ) + expect_length(as(CtwasResultEntry(), "GRanges"), 0L) + expect_error( + as(CtwasResultEntry(posteriors = data.frame(id = "g1")), "GRanges"), + "not placed on the genome" + ) +}) + test_that("CtwasResultEntry: an empty entry is valid and its accessors return NULL", { e <- CtwasResultEntry() expect_s4_class(e, "CtwasResultEntry") @@ -32,3 +45,39 @@ test_that("CtwasResultEntry: an empty entry is valid and its accessors return NU expect_null(susieAlpha(e)) expect_null(ctwasGroupPriors(e)) }) + +test_that("show() counts the genes and regions an entry scores", { + e <- CtwasResultEntry( + posteriors = data.frame( + id = c("g1", "g2", "rs1", "g1"), + type = c("gene", "gene", "SNP", "gene"), + region_id = c("r1", "r1", "r1", "r2"), + susie_pip = c(0.9, 0.1, 0.2, 0.3) + ), + groupPriors = list(group_prior = c(brain = 0.01)) + ) + expect_output( + show(e), + "CtwasResultEntry: 2 gene\\(s\\) in 2 region\\(s\\); group priors set" + ) +}) + +test_that("show() reads a ranged entry, and an empty one", { + placed <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 200L), width = 1L), + id = c("g1", "g2"), + region_id = c("r1", "r1"), + susie_pip = c(0.9, 0.1) + ) + expect_output( + show(CtwasResultEntry(posteriors = placed)), + "2 gene\\(s\\) in 1 region\\(s\\); group priors not set" + ) + # No id or region column to count, and no posteriors at all. + expect_output( + show(CtwasResultEntry(posteriors = data.frame(susie_pip = 0.5))), + "0 gene\\(s\\) in 0 region\\(s\\)" + ) + expect_output(show(CtwasResultEntry()), "0 gene\\(s\\) in 0 region\\(s\\)") +}) diff --git a/tests/testthat/test_GenotypeDosageSeed.R b/tests/testthat/test_GenotypeDosageSeed.R index 5ad2ea8e..fe7687ae 100644 --- a/tests/testthat/test_GenotypeDosageSeed.R +++ b/tests/testthat/test_GenotypeDosageSeed.R @@ -5,16 +5,16 @@ context("GenotypeDosageSeed") # FORMAT/DS shapes, both SNPRelate storage orders, and SeqArray's 2-bit # planes. +.vcfOverlapDs <- function() { + `[<-`(.vcfOverlapGt(), 1L, , value = c(0.1, 0.9, 1.8)) +} + 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() diff --git a/tests/testthat/test_GenotypeMixture.R b/tests/testthat/test_GenotypeMixture.R index ea3cf3cc..00ebe0ff 100644 --- a/tests/testthat/test_GenotypeMixture.R +++ b/tests/testthat/test_GenotypeMixture.R @@ -18,10 +18,12 @@ test_that("GenotypeMixture aligns its panels to the variants they share", { 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))) + # The canonical ids the shared ranges render, not the panels' labels. expect_identical( variantIds(mix), - as.character(SummarizedExperiment::rowRanges(p$full)$SNP) + pecotmr:::.grVariantIds(SummarizedExperiment::rowRanges(p$full)) ) + expect_true(all(str_detect(variantIds(mix), "^chr21:[0-9]+:[ACGT]+:"))) # 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)) @@ -354,10 +356,12 @@ test_that("an LD statistic reads a mixture's blocks as LdMatrix ones", { 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]]) + blocks <- GenomicRanges::GRanges( + "chr21", + IRanges::IRanges( + c(pos[[1L]], pos[[101L]]), + c(pos[[100L]], pos[[250L]]) + ) ) lazy <- buildLdScore(mix, ldBlocks = blocks, genome = "hg19") expect_identical(ldReference(lazy), mix) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index 4946b03e..cf2e1e50 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -14,34 +14,69 @@ test_that("GwasFineMappingResult: builds a collection keyed by 2-tuple", { expect_equal(nrow(res), 2L) }) -test_that("GwasFineMappingResult: region is derived from the variants", { - # genomicRegion() reports the element's REALIZED variant span, not a nominal - # window parsed out of blockId. A stored window had no correct update - # rule under subsetRegion() and would quietly go stale; the span is in - # sync by construction. +test_that("GwasFineMappingResult: a window comes from region, not blockId", { + # A blockId is a name, however it is spelled: it gives no window, so the + # rows keep their spans and nothing was given. e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) + e2 <- .sc_makeFineMappingRow(2, offset = 1000L) res <- GwasFineMappingResult( studyName = c("g1", "g1"), method = c("susie", "susie"), - blockId = c("chr1_1_500", "chr2_600_900"), + blockId = c("chr1_1_500", "b2"), entry = list(e1, e2) ) - reg <- genomicRegion(res) - expect_equal(as.character(GenomicRanges::seqnames(reg)), c("chr1", "chr1")) - expect_equal(GenomicRanges::start(reg), c(100L, 100L)) - expect_equal(GenomicRanges::end(reg), c(300L, 200L)) - # A synthetic blockId no longer produces a chrUn sentinel: with the span - # derived from the variants there is nothing to fabricate. + expect_identical(res$blockId, c("chr1_1_500", "b2")) + expect_identical( + as.character(genomicRegion(res)), + c("chr1:100-300", "chr1:1100-1200") + ) + expect_identical(res$regionGiven, c(FALSE, FALSE)) + # A window that leaves out its row's variants is not that row's window. + expect_error( + GwasFineMappingResult( + studyName = c("g1", "g1"), + method = c("susie", "susie"), + entry = list(e1, e2), + region = GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(1L, 600L), c(500L, 900L)) + ) + ), + "row 2: range chr2:600-900, variants at chr1:1100-1200", + fixed = TRUE + ) + expect_error( + GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(e1), + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(150L, 400L) + ) + ), + "must contain the row's variants" + ) + # With no range given there is no region column: genomicRegion() reads + # the span of the variants, which cannot drift out of step with them. res2 <- GwasFineMappingResult( studyName = "g1", method = "susie", entry = list(e1) ) - expect_equal( - as.character(GenomicRanges::seqnames(genomicRegion(res2))), - "chr1" + expect_false("region" %in% colnames(S4Vectors::mcols(res2))) + expect_false(res2$regionGiven) + expect_identical(as.character(genomicRegion(res2)), "chr1:100-300") + # A `region` is given, whatever the blockId. + res3 <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(e1), + blockId = "b1", + region = GenomicRanges::GRanges("chr1", IRanges::IRanges(50L, 400L)) ) + expect_true(res3$regionGiven) + expect_identical(as.character(genomicRegion(res3)), "chr1:50-400") }) @@ -80,27 +115,6 @@ test_that("GwasFineMappingResult: errors on length mismatch", { }) -test_that("GwasFineMappingResult: same (study, method), other ranges", { - # Row identity is (study, method, range), so (study, method) may repeat as - # long as the two rows cover different genomic spans. This is the - # genome-wide-across-blocks shape that qtlEnrichmentPipeline + - # colocPipeline expect, and it now needs no label to disambiguate it. - e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(3, offset = 10000L) - res <- GwasFineMappingResult( - studyName = c("g1", "g1"), - method = c("susie", "susie"), - entry = list(e1, e2) - ) - expect_s4_class(res, "GwasFineMappingResult") - expect_equal(nrow(res), 2L) - # No blockId was supplied, so the column is simply absent -- nothing - # synthesises a placeholder id any more. - expect_false(is_in("blockId", colnames(res))) - expect_equal(length(unique(.rtlRangeKeys(res))), 2L) -}) - - test_that("GwasFineMappingResult: rejects two rows covering the same range", { # Same (study, method) AND the same span: these are the same block, and no # blockId label can make them distinct -- which is the point of keying on @@ -111,7 +125,7 @@ test_that("GwasFineMappingResult: rejects two rows covering the same range", { GwasFineMappingResult( studyName = c("g1", "g1"), method = c("susie", "susie"), - blockId = c("chr22_1_100", "chr22_200_300"), + blockId = c("blockA", "blockB"), entry = list(e1, e2) ), "uniqueness violated" @@ -134,20 +148,6 @@ test_that("GwasFineMappingResult: errors when blockId length mismatches", { }) -test_that("GwasFineMappingResult: show prints summary", { - e <- .sc_makeFineMappingRow(3) - res <- GwasFineMappingResult( - studyName = "g1", - method = "susie", - entry = list(e) - ) - expect_output(show(res), "GwasFineMappingResult") -}) - -# =========================================================================== -# TwasWeights collection -# =========================================================================== - # === Tests migrated from test_showMethods.R (GwasFineMappingResult) === test_that("show.GwasFineMappingResult prints (study, method) summary", { @@ -177,19 +177,6 @@ test_that("show.GwasFineMappingResult reports the ldReference source", { # === Tests migrated from test_collectionAccessors.R (GwasFineMappingResult) === -test_that("GwasFineMappingResult: pip with study/method selectors", { - e1 <- .ca_makeFmEntry(3) - e2 <- .ca_makeFmEntry(4) - res <- GwasFineMappingResult( - studyName = c("g1", "g2"), - method = c("susie", "susie"), - entry = list(e1, e2) - ) - pip <- pip(res, studyName = "g2", method = "susie") - expect_equal(length(pip), 4L) -}) - - test_that("GwasFineMappingResult: contexts/traitNames return NULL", { e <- .ca_makeFmEntry(3) res <- GwasFineMappingResult( @@ -209,7 +196,7 @@ test_that("GwasFineMappingResult: credibleSets/topLoci/susieFit/variantIds dispa method = "susie", entry = list(e) ) - expect_equal(nrow(credibleSets(res)), 2L) + expect_equal(length(credibleSets(res)), 2L) # topLoci returns the projected posterior view (filtered by default # signalCutoff = 0.025; .ca_makeTopLoci sets all pip > 0.025 so all rows # survive). Compare on the projected shape, not the slot's raw shape. @@ -225,11 +212,11 @@ test_that("GwasFineMappingResult: topLoci aggregates per-block rows genome-wide" # With no selectors topLoci now stacks both blocks, tagging each variant # with its blockId; context/trait are NA-filled (GWAS keys on region). e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) + e2 <- .sc_makeFineMappingRow(2, offset = 1000L) res <- GwasFineMappingResult( studyName = c("g1", "g1"), method = c("susie", "susie"), - blockId = c("chr1:1-100", "chr1:200-300"), + blockId = c("chr1:1-500", "chr1:501-2000"), entry = list(e1, e2) ) agg <- topLoci(res, signalCutoff = 0) @@ -237,11 +224,11 @@ test_that("GwasFineMappingResult: topLoci aggregates per-block rows genome-wide" expect_equal( agg$blockId, c( - "chr1:1-100", - "chr1:1-100", - "chr1:1-100", - "chr1:200-300", - "chr1:200-300" + "chr1:1-500", + "chr1:1-500", + "chr1:1-500", + "chr1:501-2000", + "chr1:501-2000" ) ) expect_true(all(is.na(agg$context))) @@ -249,49 +236,71 @@ test_that("GwasFineMappingResult: topLoci aggregates per-block rows genome-wide" expect_true("variant_id" %in% names(S4Vectors::mcols(agg))) }) -test_that("GwasFineMappingResult: topLoci region= selects a single block", { +test_that("GwasFineMappingResult: topLoci picks one block by name or window", { e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) + e2 <- .sc_makeFineMappingRow(2, offset = 1000L) res <- GwasFineMappingResult( studyName = c("g1", "g1"), method = c("susie", "susie"), - blockId = c("chr1:1-100", "chr1:200-300"), + blockId = c("chr1:1-500", "chr1:501-2000"), entry = list(e1, e2) ) - # region= pins one row, so this hits the single-entry fast path (bare table). + # blockId= pins one row, so this hits the single-entry fast path (bare + # table). tl <- topLoci( res, studyName = "g1", method = "susie", - region = "chr1:200-300", + blockId = "chr1:501-2000", signalCutoff = 0 ) expect_equal(length(tl), 2L) expect_false("blockId" %in% names(S4Vectors::mcols(tl))) + # A window selects rows by subsetting the collection on its rows' + # analysis windows -- here, alone, the second block, whose variants span + # chr1:1100-1200. + byWindow <- topLoci( + res[IRanges::overlapsAny( + genomicRegion(res), + GenomicRanges::GRanges("chr1:1150-1500") + )], + signalCutoff = 0 + ) + expect_identical(as.character(byWindow), as.character(tl)) + # A window over both blocks keeps both, which then aggregate. + both <- topLoci( + res[IRanges::overlapsAny( + genomicRegion(res), + GenomicRanges::GRanges("chr1:1-5000") + )], + signalCutoff = 0 + ) + expect_equal(length(both), 5L) + expect_true("blockId" %in% names(S4Vectors::mcols(both))) }) test_that("GwasFineMappingResult: credibleSets aggregates CS across blocks", { e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) + e2 <- .sc_makeFineMappingRow(2, offset = 1000L) res <- GwasFineMappingResult( studyName = c("g1", "g1"), method = c("susie", "susie"), - blockId = c("chr1:1-100", "chr1:200-300"), + blockId = c("chr1:1-500", "chr1:501-2000"), entry = list(e1, e2) ) cs <- credibleSets(res) - expect_equal(nrow(cs), 4L) # 2 CS members per block + expect_equal(length(cs), 4L) # 2 CS members per block expect_equal( cs$blockId, - c("chr1:1-100", "chr1:1-100", "chr1:200-300", "chr1:200-300") + c("chr1:1-500", "chr1:1-500", "chr1:501-2000", "chr1:501-2000") ) expect_true(all(is.na(cs$context))) - # region= pins one block -> bare table + # blockId= pins one block -> bare table bare <- credibleSets( res, studyName = "g1", method = "susie", - region = "chr1:1-100" + blockId = "chr1:1-500" ) expect_false("blockId" %in% names(bare)) }) @@ -304,7 +313,7 @@ test_that("GwasFineMappingResult: .tupleSelectRowGwasFmr requires both selectors method = c("susie", "susie"), entry = list(e, e) ) - expect_error(pip(res), "Pass `study` and `method`") + expect_error(pip(res), "Pass `studyName` and `method`") expect_error( pip(res, studyName = c("g1", "g2"), method = "susie"), "Must have length 1" @@ -339,9 +348,11 @@ test_that("GwasFineMappingResult: marginalEffects with study/method selectors", # Collection-level selection picks the g2 entry, then delegates to the # entry-level getMarginalEffects. me <- marginalEffects(res, studyName = "g2", method = "susie") - expect_s3_class(me, "data.frame") - expect_equal(nrow(me), 4L) - expect_true(all(c("variant_id", "beta", "se", "z", "p") %in% names(me))) + expect_s4_class(me, "GRanges") + expect_equal(length(me), 4L) + expect_true(all( + c("variant_id", "beta", "se", "z", "p") %in% names(S4Vectors::mcols(me)) + )) }) # =========================================================================== @@ -380,21 +391,17 @@ test_that("validity names a missing entry payload column", { ) }) -test_that("GwasFineMappingResult: pip(returnList) keys by study|method", { - # Documented as "a per-entry list keyed by identity tuple". The QTL - # method always honoured it; this one used to ignore the flag and hand - # back the flat vector, so the list branch had no test. +test_that("GwasFineMappingResult: pip() reads the row the selectors pick", { res <- GwasFineMappingResult( studyName = c("g1", "g2"), method = c("susie", "susie"), entry = list(.ca_makeFmEntry(3), .ca_makeFmEntry(4)) ) - got <- pip(res, studyName = "g2", method = "susie", returnList = TRUE) - expect_type(got, "list") - expect_named(got, "g2|susie") - expect_equal(length(got[["g2|susie"]]), 4L) - # The flat vector is still what you get without the flag. - expect_false(is.list(pip(res, studyName = "g2", method = "susie"))) + got <- pip(res, studyName = "g2", method = "susie") + expect_type(got, "double") + expect_length(got, 4L) + # One return type: the list form is gone with its switch. + expect_error(pip(res, studyName = "g2", returnList = TRUE), "unused") }) test_that("GwasFineMappingResult: context / trait selectors are refused", { @@ -442,3 +449,207 @@ test_that("GwasFineMappingResult: context / trait selectors are refused", { 3L ) }) + +# =========================================================================== +# A study fine-mapped block by block +# =========================================================================== + +# One study fine-mapped in two LD blocks with two methods, plus a second +# study in one block. +.gfr_makeBlocked <- function() { + GwasFineMappingResult( + studyName = c("g1", "g1", "g1", "g1", "g2"), + method = c("susie", "susie", "ser", "ser", "susie"), + entry = list( + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(3, offset = 10000L), + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(3, offset = 10000L), + .sc_makeFineMappingRow(3) + ), + blockId = c( + "chr1_1_5000", + "chr1_5001_20000", + "chr1_1_5000", + "chr1_5001_20000", + "chr1_1_5000" + ) + ) +} + +test_that("pip(GwasFineMappingResult) picks a block by name or window", { + x <- .gfr_makeBlocked() + named <- pip( + x, + studyName = "g1", + method = "susie", + blockId = "chr1_5001_20000" + ) + near <- pip( + x[IRanges::overlapsAny( + genomicRegion(x), + GenomicRanges::GRanges("chr1:10100-10150") + )], + studyName = "g1", + method = "susie" + ) + expect_identical(near, named) + expect_length(named, 3L) + expect_error( + pip(x, studyName = "g1", method = "susie"), + "pass `blockId` to disambiguate" + ) +}) + +test_that("fineMappingResult returns every block of a fit, or the one named", { + x <- .gfr_makeBlocked() + fit <- fineMappingResult(x, studyName = "g1", method = "susie") + expect_s4_class(fit, "GwasFineMappingResult") + expect_equal(nrow(fit), 2L) + expect_identical(fit$blockId, c("chr1_1_5000", "chr1_5001_20000")) + one <- fineMappingResult( + x, + studyName = "g1", + method = "susie", + blockId = "chr1_5001_20000" + ) + expect_equal(nrow(one), 1L) + expect_identical(one$blockId, "chr1_5001_20000") + # Subsetting on the rows' windows keeps the blocks a window overlaps. + near <- fineMappingResult( + x[IRanges::overlapsAny( + genomicRegion(x), + GenomicRanges::GRanges("chr1:10100-10150") + )], + studyName = "g1", + method = "susie" + ) + expect_identical(near$blockId, "chr1_5001_20000") + # Selectors left unset are fine while they still name one fit. + expect_equal(nrow(fineMappingResult(x, studyName = "g2")), 1L) + expect_error( + fineMappingResult(x, studyName = "g1"), + "holds 2 \\(study, method\\) fits matching the selection" + ) + expect_error( + fineMappingResult(x, studyName = "g1", method = "susie", blockId = "z"), + "No entry for \\(study='g1', method='susie', blockId='z'\\)" + ) + expect_error( + fineMappingResult(x, method = "lasso"), + "No entry for \\(study='', method='lasso'\\)" + ) + expect_error( + fineMappingResult(x, studyName = "g1", context = "brain"), + "no context or trait axis" + ) + expect_error( + fineMappingResult(x[0L], studyName = "g1"), + "has no rows" + ) +}) + +test_that("a fit carried by a multi-chromosome entry is refused", { + # Splitting the entry by chromosome would copy its one fit onto every + # piece, and each piece would then be read as the whole fit. + ids <- c("chr1:100:A:G", "chr2:100:A:G") + tl <- data.frame(variant_id = ids, pip = c(0.6, 0.4)) + fitted <- FineMappingRow( + variantIds = ids, + susieFit = list(pip = setNames(c(0.6, 0.4), ids)), + topLoci = tl + ) + expect_error( + GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(fitted) + ), + "`entry` element\\(s\\) 1 span more than one chromosome but carry" + ) + # Without a fit there is nothing to copy, and the entry splits as before. + bare <- FineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) + split <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(bare) + ) + expect_equal(nrow(split), 2L) +}) + +test_that("filtering every variant out of a fit's blocks keeps them apart", { + skip_if_not_installed("plyranges") + x <- .gfr_makeBlocked() + # Each block becomes an empty row; its blockId keeps it distinct. + emptied <- dplyr::filter(x, pip > 2) + expect_equal(unname(lengths(emptied)), rep(0L, 5L)) + expect_identical(emptied$blockId, x$blockId) +}) + +test_that("a row without a blockId is named by its own span", { + # Row identity is (study, method, range), so one (study, method) may hold + # two blocks over other spans -- the genome-wide-across-blocks shape that + # qtlEnrichmentPipeline + colocPipeline expect. The caller named neither + # row; each is named by the stretch its variants cover, the range its + # identity already keys on. + x <- GwasFineMappingResult( + studyName = c("g1", "g1"), + method = c("susie", "susie"), + entry = list( + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(3, offset = 10000L) + ) + ) + expect_identical(x$blockId, c("chr1_100_300", "chr1_10100_10300")) + expect_identical(x$blockId, .rtlRangeKeys(x)) + # A span filled in as the id was computed, not given. + expect_identical(x$regionGiven, c(FALSE, FALSE)) + # A supplied id is kept, and an NA one filled. + y <- GwasFineMappingResult( + studyName = c("g1", "g1"), + method = c("susie", "susie"), + entry = list( + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(3, offset = 10000L) + ), + blockId = c("blockA", NA) + ) + expect_identical(y$blockId, c("blockA", "chr1_10100_10300")) + # Each chromosome piece of a fit-less entry gets its own span. + ids <- c("chr1:100:A:G", "chr2:500:A:G") + split <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(FineMappingRow( + ids, + susieFit = list(), + topLoci = data.frame(variant_id = ids, pip = c(0.6, 0.4)) + )) + ) + expect_identical(split$blockId, c("chr1_100_100", "chr2_500_500")) +}) + +test_that("GwasFineMappingResult() keeps the caller's metadata", { + res <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)), + metadata = list(run = "r1") + ) + expect_equal(S4Vectors::metadata(res), list(run = "r1")) +}) + +test_that("a fit-less entry split across chromosomes records no fit variants", { + # Its rows hold one chromosome each; with no fit there is nothing for a + # row to have narrowed, so none of them warns. + ids <- c("chr1:100:A:G", "chr2:200:C:T") + tl <- data.frame(variant_id = ids, pip = c(0.6, 0.4)) + res <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(FineMappingRow(ids, NULL, tl)) + ) + expect_equal(nrow(res), 2L) + expect_equal(unname(lengths(res$fitVariants)), c(0L, 0L)) + expect_no_warning(lbf(res)) +}) diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index 53c3a888..c1767d3c 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -1,87 +1,172 @@ -# Tests migrated from test_h2ClassesSumstats.R +# Tests for R/gwasSumStats.R (the GwasSumStats class). makeGwasSumStatsFromDf(), +# below, is a test helper over GwasSumStats(). + +makeTestSumstatsDf <- function(n = 50) { + set.seed(42) + data.frame( + SNP = paste0("rs", seq_len(n)), + CHR = rep("1", n), + BP = seq(1000, by = 100, length.out = n), + A1 = rep("A", n), + A2 = rep("G", n), + Z = rnorm(n), + N = rep(10000, n), + stringsAsFactors = FALSE + ) +} -# === Tests migrated from test_h2ClassesSumstats.R (GwasSumStats) === +# Bridge helper: turn the legacy per-study data.frame shape into a +# single-row GwasSumStats collection using the new API. Keeps the bulk of +# the per-accessor tests below readable. +.testGenotypeHandle <- function() { + new( + "GenotypeHandle", + path = "/tmp/test", + format = "plink2", + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ) +} -test_that("GwasSumStats(df) errors when required mcols are missing", { - df <- data.frame( - SNP = "rs1", - CHR = "1", - BP = 100, - A1 = "A", - stringsAsFactors = FALSE +.dfToSumstatsGr <- function(df) { + chrs <- as.character(df$CHR) + if (!all(grepl("^chr", chrs))) { + chrs <- paste0("chr", sub("^chr", "", chrs)) + } + gr <- GenomicRanges::GRanges( + seqnames = chrs, + ranges = IRanges::IRanges(start = as.integer(df$BP), width = 1L) ) - expect_error( - makeGwasSumStatsFromDf(df), - "Missing required columns" + mc <- df[, setdiff(colnames(df), c("CHR", "BP")), drop = FALSE] + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mc) + gr +} + +makeGwasSumStatsFromDf <- function( + df, + traitName = "test", + genome = "hg19", + varY = NA_real_ +) { + if (is.null(varY)) { + varY <- NA_real_ + } + GwasSumStats( + studyName = traitName, + entry = list(.dfToSumstatsGr(df)), + genome = genome, + ldReference = .testGenotypeHandle(), + varY = varY ) -}) +} +# A handle over a real (fake-path) variant set, so tests can build the +# per-block LD panels a block-parallel pipeline produces: same genotype source, +# each narrowed to its own variants. +.blockGenotypeHandle <- function(bp, path = "/tmp/test.pgen") { + new( + "GenotypeHandle", + path = path, + format = "plink2", + snpInfo = data.frame( + SNP = paste0("chr1:", bp, ":A:G"), + CHR = rep("chr1", length(bp)), + BP = as.integer(bp), + A1 = rep("G", length(bp)), + A2 = rep("A", length(bp)), + fileIdx = seq_along(bp), + stringsAsFactors = FALSE + ), + nSamples = 10L, + sampleIds = paste0("s", seq_len(10)), + pgenPtr = NULL + ) +} -test_that("GwasSumStats valid object passes with all required mcols", { - set.seed(1) +# One LD block's worth of GWAS summary statistics: `n` variants starting at +# `start`, carrying a QC record and an LD panel narrowed to just those +# variants (what a per-block pipeline step writes out). +makeGwasBlock <- function( + blockId, + start, + n = 5L, + genome = "hg19", + qcOptions = list(mafCutoff = 0.01), + ldReference = .blockGenotypeHandle(bp) +) { + bp <- seq(start, by = 100L, length.out = n) df <- data.frame( - SNP = paste0("rs", 1:5), - CHR = rep("1", 5), - BP = 1:5, - A1 = rep("A", 5), - A2 = rep("G", 5), - Z = rnorm(5), - N = rep(1000, 5), + SNP = paste0("chr1:", bp, ":A:G"), + CHR = rep("1", n), + BP = bp, + A1 = rep("A", n), + A2 = rep("G", n), + Z = seq_len(n) / 10, + N = rep(1000L, n), stringsAsFactors = FALSE ) - obj <- makeGwasSumStatsFromDf(df) - expect_true(methods::validObject(obj)) -}) - + obj <- GwasSumStats( + studyName = "trait1", + entry = list(.dfToSumstatsGr(df)), + genome = genome, + ldReference = ldReference, + blockId = blockId, + qcOptions = list(timestamp = NA_character_, options = qcOptions) + ) + obj$qcAudit <- S4Vectors::SimpleList(list(list( + variantsIn = n, + block = blockId + ))) + obj +} -test_that("makeGwasSumStatsFromDf() constructor creates object from data.frame", { +test_that("GwasSumStats() records the study, genome build and variants", { df <- makeTestSumstatsDf(20) obj <- makeGwasSumStatsFromDf(df, traitName = "height", genome = "hg38") expect_s4_class(obj, "GwasSumStats") - expect_equal(as.character(obj$study)[[1L]], "height") + expect_true(methods::validObject(obj)) + # One chromosome, so one row, keyed on the study it was given. + expect_identical(obj$study, "height") expect_equal(unname(GenomeInfoDb::genome(obj)), "hg38") - expect_equal(length(sumStats(obj)), 20) + expect_identical(sumStats(obj)$SNP, df$SNP) }) -test_that("makeGwasSumStatsFromDf() normalizes chr prefix", { - df <- makeTestSumstatsDf(5) - # Input has CHR = "1" (no prefix) - obj <- makeGwasSumStatsFromDf(df) - chrs <- as.character(GenomicRanges::seqnames(sumStats(obj))) - expect_true(all(startsWith(chrs, "chr"))) - - # Input already has "chr" prefix - df2 <- df - df2$CHR <- "chr1" - obj2 <- makeGwasSumStatsFromDf(df2) - chrs2 <- as.character(GenomicRanges::seqnames(sumStats(obj2))) - # Should not double-prefix - expect_true(all(chrs2 == "chr1")) - expect_false(any(grepl("^chrchr", chrs2))) -}) - - -test_that("makeGwasSumStatsFromDf() errors on missing columns", { - df <- data.frame(SNP = "rs1", CHR = "1", BP = 100) - expect_error(makeGwasSumStatsFromDf(df), "Missing required columns") -}) - - -test_that("makeGwasSumStatsFromDf() removes rows with NA in required columns", { - df <- makeTestSumstatsDf(10) - df$Z[1] <- NA - df$N[3] <- NA - expect_message( - obj <- makeGwasSumStatsFromDf(df), - "Removed.*SNPs with missing" +test_that("GwasSumStats() reads an entry's chromosomes in UCSC style", { + # Built here rather than through makeGwasSumStatsFromDf(), which adds + # the "chr" prefix itself before the constructor sees the names. + gr <- GenomicRanges::GRanges( + c("1", "1", "CHR2"), + IRanges::IRanges(c(100L, 200L, 300L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c("rs1", "rs2", "rs3"), + A1 = "A", + A2 = "G", + Z = c(1, 2, 3), + N = 100L + ) + obj <- GwasSumStats(studyName = "t1", entry = list(gr), genome = "hg19") + expect_identical( + as.character(GenomicRanges::seqnames(sumStats(obj))), + c("chr1", "chr1", "chr2") + ) + # The per-chromosome rows are keyed on the renamed chromosomes. + expect_identical(obj$blockId, c("chr1", "chr2")) + # Names already in UCSC style are kept, not prefixed a second time. + again <- GwasSumStats( + studyName = "t1", + entry = list(sumStats(obj)), + genome = "hg19" ) - expect_equal(length(sumStats(obj)), 8) + expect_identical(GenomeInfoDb::seqlevels(again), c("chr1", "chr2")) }) -test_that("getz() returns correct Z vector", { +test_that("z() returns correct Z vector", { set.seed(99) df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) @@ -91,16 +176,16 @@ test_that("getz() returns correct Z vector", { }) -test_that("getn() returns correct N vector", { +test_that("sampleSize() returns correct N vector", { df <- makeTestSumstatsDf(5) obj <- makeGwasSumStatsFromDf(df) - n <- nSamples(obj) + n <- sampleSize(obj) expect_equal(length(n), 5) expect_true(all(n == 10000)) }) -test_that("getmaf() returns MAF when present, NULL when absent", { +test_that("maf() returns MAF when present, NULL when absent", { df <- makeTestSumstatsDf(5) obj_no_maf <- makeGwasSumStatsFromDf(df) expect_null(maf(obj_no_maf)) @@ -120,23 +205,22 @@ test_that("nSnps() returns correct count", { }) -test_that("subsetchr() filters correctly", { +test_that("keepSeqlevels() narrows a GwasSumStats to a chromosome", { df <- makeTestSumstatsDf(10) df$CHR <- c(rep("1", 6), rep("2", 4)) obj <- makeGwasSumStatsFromDf(df) - chr1 <- subsetChr(obj, "1") + chr1 <- GenomeInfoDb::keepSeqlevels(obj, "chr1", pruning.mode = "coarse") + expect_s4_class(chr1, "GwasSumStats") expect_equal(nSnps(chr1), 6) - - # Also works with "chr" prefix - chr2 <- subsetChr(obj, "chr2") + chr2 <- GenomeInfoDb::keepSeqlevels(obj, "chr2", pruning.mode = "coarse") expect_equal(nSnps(chr2), 4) }) -test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { - # Regression: the chromosome subset rebuilds the GwasSumStats and previously - # dropped the optional per-study case/control counts + total N. +test_that("keepSeqlevels() preserves study-level nCase/nControl/nSample", { + # The per-study case/control counts and total N are row columns, so a + # chromosome subset carries them with the rows it keeps. gr <- GenomicRanges::GRanges( c("chr1", "chr1", "chr2"), IRanges::IRanges(start = c(100L, 200L, 300L), width = 1L) @@ -158,7 +242,7 @@ test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { nSample = 20000 ) - sub <- subsetChr(obj, "chr1") + sub <- GenomeInfoDb::keepSeqlevels(obj, "chr1", pruning.mode = "coarse") expect_equal(nSnps(sub), 2) expect_equal(as.numeric(sub$nCase), 5000) expect_equal(as.numeric(sub$nControl), 15000) @@ -166,7 +250,7 @@ test_that("subsetChr() preserves study-level nCase/nControl/nSample scalars", { }) -test_that("getvary() returns var_y and NULL cases", { +test_that("varY() returns var_y and NULL cases", { df <- makeTestSumstatsDf(5) obj_null <- makeGwasSumStatsFromDf(df, varY = NULL) @@ -177,15 +261,16 @@ test_that("getvary() returns var_y and NULL cases", { }) -test_that("as.data.frame() round-trips in the standardized layout", { +test_that("as.data.frame() is the standard coercion, one row per variant", { df_in <- makeTestSumstatsDf(15) obj <- makeGwasSumStatsFromDf(df_in) - df_out <- as.data.frame(obj) - - # One coercion per class: as.data.frame() is the table view of - # sumStats(), so it yields the standardized layout rather than the raw - # mcols names. The raw form is still reachable through - # as.data.frame(mcols(sumStats(obj))). + # The inherited GRangesList coercion: the element ranges plus their + # stored mcols, under the stored names. + std <- as.data.frame(obj) + expect_true(all(c("group", "seqnames", "start", "Z") %in% names(std))) + expect_equal(nrow(std), 15) + # The standardized layout the pipelines use is built internally. + df_out <- pecotmr:::.entryToSumstatDf(sumStats(obj)) expect_true(is.data.frame(df_out)) expect_true(all( c("variant_id", "chrom", "pos", "A1", "A2", "z", "N") %in% @@ -199,11 +284,9 @@ test_that("as.data.frame() round-trips in the standardized layout", { # ============================================================================= -# AnnotationMatrix (h2Annotations.R) +# show() # ============================================================================= -# === Tests migrated from test_showMethods.R (GwasSumStats) === - test_that("show.GwasSumStats prints nrow and genome build", { ss <- GwasSumStats( studyName = c("g1", "g2"), @@ -212,11 +295,34 @@ test_that("show.GwasSumStats prints nrow and genome build", { ldReference = .sh_makeGenotypeHandle() ) out <- capture.output(show(ss)) - expect_true(any(grepl("GwasSumStats: 2 studies, genome build hg19", out))) + expect_true(any(grepl( + "GwasSumStats: 2 studies in 2 rows, genome build hg19", + out + ))) expect_true(any(grepl("LD reference: plink2 @ /tmp/test", out))) }) -# === Tests migrated from test_h2ClassesSumstats.R (showMethods) === +test_that("show.GwasSumStats counts a study split across chromosomes once", { + gr <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 100L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c("chr1:100:A:G", "chr2:100:A:G"), + A1 = "A", + A2 = "G", + Z = c(1, 2), + N = 100L + ) + ss <- GwasSumStats(studyName = "g1", entry = list(gr), genome = "hg19") + expect_equal(nrow(ss), 2L) + out <- capture.output(show(ss)) + # One header line, not one per chromosome the study spans. + expect_identical( + grep("^GwasSumStats:", out, value = TRUE), + "GwasSumStats: 1 studies in 2 rows, genome build hg19" + ) +}) # ============================================================================= # GwasSumStats() constructor validation + accessor error branches @@ -327,8 +433,9 @@ test_that("GwasSumStats: ldReference is optional (NULL when LD-free)", { studyName = "g1", entry = list(.sh_makeQtlSumstatsGr()), genome = "hg19" - ) # ldReference omitted -> NULL - expect_null(ldReference(ss)) + ) # ldReference omitted -> LD-free + expect_identical(ldReference(ss), list()) + expect_true(is.na(ss$ldReference)) expect_output(show(ss), "none \\(LD-free\\)") }) @@ -344,15 +451,8 @@ test_that("GwasSumStats: a non-GenotypeHandle ldReference is rejected", { ) }) -# show() smoke test, moved here from test_showMethods.R so the test -# tree mirrors R/. -test_that("show(GwasSumStats) does not error", { - ss <- makeGwasSumStatsFromDf(makeTestSumstatsDf(10)) - expect_output(show(ss), "GwasSumStats") -}) - -# blockId + ldBlocks (§4.2). A genome-wide GWAS split by seqname gives one +# blockId + region (§4.2). A genome-wide GWAS split by seqname gives one # element per chromosome, which is too coarse for cTWAS: its EM estimates # parameters across LD blocks. `blockId` is always present so downstream code # can key regions without asking how the collection was built. @@ -371,7 +471,7 @@ test_that("show(GwasSumStats) does not error", { } # @noRd -.gss_ldBlocks <- function() { +.gss_blocks <- function() { b <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(c(1L, 800L), c(500L, 1200L)) @@ -394,7 +494,7 @@ test_that("GwasSumStats splits by LD block when a manifest is supplied", { studyName = "t1", entry = list(g), genome = "hg38", - ldBlocks = .gss_ldBlocks() + region = .gss_blocks() ) # Same chromosome, so the seqname split would have left ONE element; the # manifest is what produces per-block granularity. @@ -411,7 +511,7 @@ test_that("GwasSumStats replicates the study row against each block", { entry = list(g), genome = "hg38", varY = 2, - ldBlocks = .gss_ldBlocks() + region = .gss_blocks() ) expect_equal(x$study, c("t1", "t1")) expect_equal(x$varY, c(2, 2)) @@ -424,7 +524,7 @@ test_that("GwasSumStats warns about variants outside every LD block", { studyName = "t1", entry = list(g), genome = "hg38", - ldBlocks = .gss_ldBlocks() + region = .gss_blocks() ), "1 variant" ) @@ -439,7 +539,7 @@ test_that("GwasSumStats keeps blockId aligned across two studies", { .gss_variants("chr1", 900L) ), genome = "hg38", - ldBlocks = .gss_ldBlocks() + region = .gss_blocks() ) expect_equal(x$study, c("t1", "t1", "t2")) expect_equal(x$blockId, c("b1", "b2", "b2")) @@ -450,13 +550,13 @@ test_that("GwasSumStats blockId survives subsetting", { studyName = "t1", entry = list(.gss_variants("chr1", c(100L, 900L))), genome = "hg38", - ldBlocks = .gss_ldBlocks() + region = .gss_blocks() ) expect_equal(x[2L]$blockId, "b2") }) # =========================================================================== -# Block-key resolution: ldBlocks vs blockId +# Block-key resolution: region vs blockId # # Both arguments answer "how is this entry split into elements", so supplying # both is ambiguous rather than redundant. Neither error branch had a test. @@ -485,13 +585,13 @@ test_that("GwasSumStats blockId survives subsetting", { gr } -test_that("supplying both ldBlocks and blockId is refused", { +test_that("supplying both region and blockId is refused", { expect_error( GwasSumStats( studyName = "g1", entry = list(.gss_entry()), genome = "hg19", - ldBlocks = GenomicRanges::GRanges( + region = GenomicRanges::GRanges( "chr1", IRanges::IRanges(1L, 10000L) ), @@ -555,12 +655,12 @@ test_that("combineGwasSumStats() concatenates the per-element QC audit", { b <- makeGwasBlock("chr1_1001_2000", 1100L, n = 3L) out <- combineGwasSumStats(a, b) - audit <- qcInfo(out)$entryAudit + audit <- out$qcAudit expect_length(audit, nrow(out)) # element i's audit still describes element i expect_equal(audit[[1L]]$block, "chr1_1_1000") expect_equal(audit[[2L]]$block, "chr1_1001_2000") - expect_equal(qcInfo(out)$options, qcInfo(a)$options) + expect_equal(qcOptions(out)$options, qcOptions(a)$options) }) @@ -569,13 +669,16 @@ test_that("combineGwasSumStats() unions the per-block LD panels", { b <- makeGwasBlock("chr1_1001_2000", 1100L, n = 3L) out <- combineGwasSumStats(a, b) - # Keeping only the first block's panel would leave a two-block collection - # whose LD reference covers one block. - expect_equal(nrow(ldReference(out)), 8L) + # Each block's panel was narrowed to its own variants, but one panel's + # files back both, so the bound collection holds them once, unioned. + refs <- ldReference(out) + expect_length(refs, 1L) + expect_equal(nrow(refs[[1L]]), 8L) expect_equal( - rownames(ldReference(out)), - c(rownames(ldReference(a)), rownames(ldReference(b))) + rownames(refs[[1L]]), + c(rownames(ldReference(a)[[1L]]), rownames(ldReference(b)[[1L]])) ) + expect_equal(unique(out$ldReference), names(refs)) }) @@ -609,24 +712,33 @@ test_that("combineGwasSumStats() rejects collection-level disagreement", { "different summaryStatsQc\\(\\) options" ) noQc <- makeGwasBlock("chr1_1001_2000", 1100L) - noQc@qcInfo <- list() + noQc@qcOptions <- list() expect_error(combineGwasSumStats(a, noQc), "carry no QC record") +}) - noLd <- makeGwasBlock("chr1_1001_2000", 1100L) - noLd@ldReference <- NULL - expect_error(combineGwasSumStats(a, noLd), "carry no ldReference") - other <- makeGwasBlock("chr1_1001_2000", 1100L) - other@ldReference <- pecotmr:::.asLdRef( - .blockGenotypeHandle( +test_that("combineGwasSumStats() keeps each row on its own LD reference", { + a <- makeGwasBlock("chr1_1_1000", 100L) + other <- makeGwasBlock( + "chr1_1001_2000", + 1100L, + ldReference = .blockGenotypeHandle( seq(1100L, by = 100L, length.out = 5L), path = "/tmp/other.pgen" ) ) - expect_error( - combineGwasSumStats(a, other), - "different genotype panels" + out <- combineGwasSumStats(a, other) + # Panels read from different files cannot be unioned, so both are kept. + expect_length(ldReference(out), 2L) + expect_identical( + pecotmr:::.rowLdRefs(out), + list(ldReference(a)[[1L]], ldReference(other)[[1L]]) ) + # An LD-free part's rows stay LD-free beside them. + noLd <- makeGwasBlock("chr1_2001_3000", 2100L, ldReference = NULL) + mixed <- combineGwasSumStats(a, noLd) + expect_equal(is.na(mixed$ldReference), c(FALSE, TRUE)) + expect_length(ldReference(mixed), 1L) }) @@ -640,8 +752,9 @@ test_that("combineGwasSumStats() validates its inputs", { test_that("sumStats(GwasSumStats) refuses the QtlSumStats selectors", { # The shared SumStatsBase accessors pass the union of both classes' - # selectors, so a GWAS sees context / trait / annotateSignificance. It - # names them in order to reject them, rather than absorbing them in `...`. + # selectors, so a GWAS sees context / trait, and sumStats() also takes + # annotateSignificance. It names them in order to reject them, rather + # than absorbing them in `...`. gss <- GwasSumStats( studyName = "g1", entry = list(.gss_entry()), @@ -659,3 +772,207 @@ test_that("sumStats(GwasSumStats) refuses the QtlSumStats selectors", { expect_s4_class(sumStats(gss), "GRanges") expect_type(z(gss), "double") }) + +test_that("varY reads one value for a study split across rows", { + gr <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 100L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c("chr1:100:A:G", "chr2:100:A:G"), + A1 = "A", + A2 = "G", + Z = c(1, 2), + N = 100L + ) + ss <- GwasSumStats( + studyName = "g1", + entry = list(gr), + genome = "hg19", + varY = 4 + ) + expect_equal(nrow(ss), 2L) + expect_equal(varY(ss), 4) + # Rows of one study that disagree have no single answer. + split <- GwasSumStats( + studyName = c("g1", "g1"), + entry = list(gr[1L], gr[2L]), + genome = "hg19", + varY = c(1, 2), + blockId = c("a", "b") + ) + expect_error(varY(split), "the 2 rows of study 'g1' disagree on varY") +}) + +test_that("GwasSumStats records each row's window and its origin", { + data(gwasSumStatsS4Example) + gr <- sumStats(gwasSumStatsS4Example) + cut <- GenomicRanges::start(gr)[[100L]] + # A `region` gives each window its interval, however it is keyed. + blocks <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(1L, cut + 1L), c(cut, 60000000L)) + ) + names(blocks) <- c("b1", "b2") + x <- GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = blocks + ) + expect_identical(x$blockId, c("b1", "b2")) + expect_identical(x$regionGiven, c(TRUE, TRUE)) + expect_identical( + as.character(x$region), + c(str_c("chr22:1-", cut), str_c("chr22:", cut + 1L, "-60000000")) + ) + # Read from a BED file, a window's start is 0-based and the fourth column + # names it. The variants past its one window are dropped, with a warning. + bedPath <- withr::local_tempfile(fileext = ".bed") + writeLines(str_c("chr22\t0\t", cut, "\tb1"), bedPath) + expect_warning( + bed <- GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = bedPath + ), + "100 variant(s) lie outside every `region` window", + fixed = TRUE + ) + expect_identical(bed$blockId, "b1") + expect_identical(as.character(bed$region), str_c("chr22:1-", cut)) + # Given in R, a window is a GRanges: a table is refused, not read. + expect_error( + GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = data.frame(chrom = "chr22", start = 1L, end = cut) + ), + "must be a GRanges or the path of a BED file" + ) + # A blockId is a name and gives no window, however it is spelled: each + # row's window is its variants' span. + y <- GwasSumStats( + studyName = c("s", "s"), + entry = list(gr[1:100], gr[101:200]), + genome = "hg19", + blockId = c("chr22_1_15700000", "b2") + ) + expect_identical(y$blockId, c("chr22_1_15700000", "b2")) + expect_identical(y$regionGiven, c(FALSE, FALSE)) + expect_identical( + as.character(y$region), + c(as.character(range(gr[1:100])), as.character(range(gr[101:200]))) + ) + # One set of windows per study, or none for a study split by chromosome. + per <- suppressWarnings(GwasSumStats( + studyName = c("s", "t"), + entry = list(gr, gr), + genome = "hg19", + region = list(blocks[1L], NULL) + )) + expect_identical(per$study, c("s", "t")) + expect_identical(per$blockId, c("b1", "chr22")) + expect_identical(per$regionGiven, c(TRUE, FALSE)) + expect_error( + GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = list(blocks, blocks) + ), + "one element per `entry`" + ) + # Split by chromosome, a row's window is its variants' span. + z <- GwasSumStats(studyName = "s", entry = list(gr), genome = "hg19") + expect_false(z$regionGiven) + expect_identical(as.character(z$region), "chr22:14560203-15826991") +}) + +test_that("combineGwasSumStats() carries each row's block range through", { + data(gwasSumStatsS4Example) + gr <- sumStats(gwasSumStatsS4Example) + given <- GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = GenomicRanges::GRanges("chr22:1-20000000") + ) + computed <- GwasSumStats(studyName = "t", entry = list(gr), genome = "hg19") + both <- combineGwasSumStats(given, computed) + expect_identical(both$regionGiven, c(TRUE, FALSE)) + expect_identical( + as.character(both$region), + c("chr22:1-20000000", "chr22:14560203-15826991") + ) +}) + +# === metadata, qcOptions and a tabular extraCols === + +test_that("GwasSumStats() takes extra columns as a DataFrame or data.frame", { + build <- function(extra) { + GwasSumStats( + studyName = c("g1", "g2"), + entry = list(.sh_makeQtlSumstatsGr(), .sh_makeQtlSumstatsGr()), + genome = "hg19", + ldReference = .sh_makeGenotypeHandle(), + extraCols = extra + ) + } + cohorts <- c("UKB", "FinnGen") + fromDf <- build(S4Vectors::DataFrame(cohort = cohorts, wave = 1:2)) + expect_equal(fromDf$cohort, cohorts) + expect_equal(fromDf$wave, 1:2) + expect_equal(build(data.frame(cohort = cohorts))$cohort, cohorts) +}) + +test_that("GwasSumStats() keeps the caller's metadata and QC options", { + obj <- GwasSumStats( + studyName = "g1", + entry = list(.sh_makeQtlSumstatsGr()), + genome = "hg19", + ldReference = .sh_makeGenotypeHandle(), + qcOptions = list(step1 = "ok"), + metadata = list(source = "unit test") + ) + expect_equal(S4Vectors::metadata(obj), list(source = "unit test")) + expect_equal(qcOptions(obj), list(step1 = "ok")) +}) + +# =========================================================================== +# nCase and nControl +# =========================================================================== + +test_that("GwasSumStats: nCase/nControl are optional columns (absent by default)", { + gr <- GenomicRanges::GRanges( + seqnames = "chr1", + ranges = IRanges::IRanges( + start = seq(100L, by = 100L, length.out = 5L), + width = 1L + ) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = rnorm(5), + N = rep(1000L, 5) + ) + base <- list( + study = "G1", + entry = list(gr), + genome = "hg19", + ldReference = .cbp_makeHandle(), + qcOptions = list(ok = 1) + ) + g0 <- exec(GwasSumStats, !!!base) + expect_false(any( + c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g0)) + )) + g1 <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) + expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g1)))) + expect_equal(g1$nCase, 500) + expect_equal(g1$nControl, 1500) +}) diff --git a/tests/testthat/test_H2Estimate.R b/tests/testthat/test_H2Estimate.R index c5b2685e..20407a6a 100644 --- a/tests/testthat/test_H2Estimate.R +++ b/tests/testthat/test_H2Estimate.R @@ -1,7 +1,3 @@ -# Tests migrated from test_h2ClassesSumstats.R - -# === Tests migrated from test_h2ClassesSumstats.R (H2Estimate) === - test_that("H2Estimate constructs with all slots", { obj <- new( "H2Estimate", @@ -22,8 +18,6 @@ test_that("H2Estimate constructs with all slots", { expect_equal(methodNames(obj), "lder") }) -# show() smoke test, moved here from test_showMethods.R so the test -# tree mirrors R/. test_that("show(H2Estimate) does not error", { h2 <- new( "H2Estimate", @@ -79,3 +73,89 @@ test_that("H2Estimate types its optional slots", { 'invalid object for slot "scoreStats"' ) }) + +# =========================================================================== +# H2Estimate accessors +# =========================================================================== + +test_that("stratifiedHeritabilityEnrichment returns the enrichment slot", { + h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) + result <- stratifiedHeritabilityEnrichment(h2_obj) + expect_true(is.data.frame(result)) + expect_equal(result$annotation, c("annot1", "annot2")) +}) + +test_that("scoreStats returns the scoreStats slot", { + scoreStats <- list( + z = c(1.5, -0.8), + R = diag(2), + annotationNames = c("a1", "a2") + ) + h2_obj <- new( + "H2Estimate", + estimate = 0.3, + estimateSe = 0.05, + intercept = 1.0, + interceptSe = 0.01, + localBlocks = NULL, + enrichment = NULL, + annotationJackknifeCoefs = NULL, + scoreStats = scoreStats, + method = "lder", + nSnps = 100L, + traitName = "test" + ) + expect_identical(scoreStats(h2_obj), scoreStats) +}) + +test_that("accessors return NULL when slots are NULL", { + h2_obj <- new( + "H2Estimate", + estimate = 0.3, + estimateSe = 0.05, + intercept = 1.0, + interceptSe = 0.01, + localBlocks = NULL, + enrichment = NULL, + annotationJackknifeCoefs = NULL, + scoreStats = NULL, + method = "lder", + nSnps = 100L, + traitName = "test" + ) + expect_null(localH2Blocks(h2_obj)) + expect_null(stratifiedHeritabilityEnrichment(h2_obj)) + expect_null(scoreStats(h2_obj)) +}) + +test_that("updateObject() moves an H2Estimate's estimates off the old names", { + h2Obj <- new( + "H2Estimate", + estimate = 0.3, + estimateSe = 0.05, + intercept = 1.0, + interceptSe = 0.01, + localBlocks = data.frame(blockId = "b1", h2Local = 0.1, h2LocalSe = 0), + enrichment = NULL, + annotationJackknifeCoefs = matrix(0.2, nrow = 2L, ncol = 1L), + scoreStats = NULL, + method = "sldsc", + nSnps = 100L, + traitName = "test" + ) + saved <- .savedUnder( + h2Obj, + c( + h2 = "estimate", + h2Se = "estimateSe", + local = "localBlocks", + tauBlocks = "annotationJackknifeCoefs" + ) + ) + # The inherited update alone drops slots the class no longer has, with a + # warning, and leaves the estimate empty. + expect_no_warning(up <- updateObject(saved)) + expect_identical(up, h2Obj) + expect_identical(updateObject(h2Obj), h2Obj) + expect_message(updateObject(h2Obj, verbose = TRUE), "H2Estimate") +}) diff --git a/tests/testthat/test_LdBlocks.R b/tests/testthat/test_LdBlocks.R index 67451948..43c75070 100644 --- a/tests/testthat/test_LdBlocks.R +++ b/tests/testthat/test_LdBlocks.R @@ -4,7 +4,7 @@ # string; it was retired because GRanges already carries the build in # seqinfo() and its only consumer, LdStatistic, has its own genome slot. What # remains is .asLdBlockRanges(), the one place an LD-block specification -# becomes the GRanges the splitters consume. +# becomes the GRanges the splitters consume: a GRanges, or a BED file. # @noRd .ldb_blocks <- function() { @@ -16,52 +16,70 @@ b } +# @noRd +.ldb_bedFile <- function(lines) { + path <- withr::local_tempfile( + fileext = ".bed", + .local_envir = parent.frame() + ) + writeLines(lines, path) + path +} + test_that(".asLdBlockRanges passes a GRanges through unchanged", { expect_identical(.asLdBlockRanges(.ldb_blocks()), .ldb_blocks()) }) -test_that(".asLdBlockRanges builds ranges from a block table", { - df <- data.frame( - chrom = "chr1", - start = c(1L, 800L), - end = c(500L, 1200L), - stringsAsFactors = FALSE - ) - gr <- .asLdBlockRanges(df) +test_that(".asLdBlockRanges reads a BED file with BED's 0-based start", { + gr <- .asLdBlockRanges(.ldb_bedFile(c("chr1\t0\t500", "chr1\t799\t1200"))) expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 2L) expect_equal(start(gr), c(1L, 800L)) + expect_equal(end(gr), c(500L, 1200L)) + expect_null(mcols(gr)$blockId) }) -test_that(".asLdBlockRanges carries blockId from the table into mcols", { +test_that(".asLdBlockRanges takes a BED file's fourth column as the names", { # Without this the splitter would fall back to coordinate keys, and the - # caller's own block names would be silently discarded. - df <- data.frame( - chrom = "chr1", - start = c(1L, 800L), - end = c(500L, 1200L), - blockId = c("a", "b"), - stringsAsFactors = FALSE + # file's own block names would be silently discarded. + path <- .ldb_bedFile(c("chr1\t0\t500\ta", "chr1\t799\t1200\tb")) + expect_equal(mcols(.asLdBlockRanges(path))$blockId, c("a", "b")) +}) + +test_that(".asLdBlockRanges passes over BED comments and a header line", { + # An LD-block file often names its columns, as LDetect's `chr start stop` + # does; BED's columns are positional, so the header line is skipped. + path <- .ldb_bedFile(c( + "track name=blocks", + "# LD blocks", + "chr\tstart\tstop", + "chr1\t0\t500", + "" + )) + expect_identical(as.character(.asLdBlockRanges(path)), "chr1:1-500") +}) + +test_that(".asLdBlockRanges refuses a file that is not BED", { + expect_error( + .asLdBlockRanges(.ldb_bedFile(c("chr1\t0\t500", "chr1 799 1200"))), + "is not a BED file" ) - expect_equal(mcols(.asLdBlockRanges(df))$blockId, c("a", "b")) + expect_error(.asLdBlockRanges(.ldb_bedFile(character(0))), "not a BED") }) -test_that(".asLdBlockRanges reads a block table from a path", { - df <- data.frame( - chrom = "chr1", - start = c(1L, 800L), - end = c(500L, 1200L), - stringsAsFactors = FALSE +test_that(".asLdBlockRanges refuses a table, which R calls give 1-based", { + # Given in R a window is a GRanges, so a table -- whose start could be + # either base -- is refused rather than read. + df <- data.frame(chrom = "chr1", start = c(1L, 800L), end = c(500L, 1200L)) + expect_error( + .asLdBlockRanges(df), + "`ldBlocks` must be a GRanges or the path of a BED file" ) - tf <- withr::local_tempfile(fileext = ".tsv") - readr::write_tsv(df, tf, progress = FALSE) - expect_equal(length(.asLdBlockRanges(tf)), 2L) }) -test_that(".asLdBlockRanges names the columns a block table is missing", { +test_that(".asLdBlockRanges names a path that does not exist", { expect_error( - .asLdBlockRanges(data.frame(chrom = "chr1", start = 1L)), - "end" + .asLdBlockRanges("chr1:1-500"), + "no file exists at 'chr1:1-500'" ) }) diff --git a/tests/testthat/test_LdMatrix.R b/tests/testthat/test_LdMatrix.R index 67efd6ab..b9189ccf 100644 --- a/tests/testthat/test_LdMatrix.R +++ b/tests/testthat/test_LdMatrix.R @@ -64,6 +64,13 @@ test_that("LdMatrix takes its variants from a table or a GRanges", { ) }) +test_that("as.matrix() and as(x, 'matrix') return the correlation matrix", { + f <- .ldmFixture() + ld <- LdMatrix(cor(f$X), nSamples = nrow(f$X)) + expect_identical(as.matrix(ld), ldMatrix(ld)) + expect_identical(as(ld, "matrix"), ldMatrix(ld)) +}) + test_that("an unlabelled matrix without variants is refused", { f <- .ldmFixture() expect_error(LdMatrix(unname(f$R)), "`variants` is required") diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index 7efc731b..d7c40eaf 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -28,9 +28,9 @@ test_that("genome() reports the build from seqinfo (via an LdScore)", { # =========================================================================== # Overrides REPLACE the defaults rather than being appended: forwarding `...` -# alongside a fixed `nRef = 500L` makes .lds_score(nRef = 0L) fail with -# "formal argument matched by multiple actual arguments", which an -# expect_error(., "nRef") happily matches without ever reaching validity. +# alongside a fixed `nSamples = 500L` makes .lds_score(nSamples = 0L) fail +# with "formal argument matched by multiple actual arguments", which an +# expect_error(., "nSamples") happily matches without ever reaching validity. .lds_score <- function(n = 10, ...) { args <- list( ldBlocks = makeTestLdBlocks(), @@ -60,8 +60,9 @@ test_that("validity rejects an nSamples that is not a positive integer", { test_that("validity rejects an inSample that is not a single flag", { # Through new(), not LdScore(): the constructor writes # `inSample = isTRUE(inSample)`, so a multi-element or empty flag is - # collapsed before validity can see it. (`nRef = as.integer(nRef)` does - # not collapse length, which is why the nRef branch IS reachable above.) + # collapsed before validity can see it. (`nSamples = as.integer(nSamples)` + # does not collapse length, which is why the nSamples branch IS reachable + # above.) # This one guards direct new() use -- migration scripts, deserialization. gr <- as(.lds_score(), "GRanges") msg <- "Variable 'inSample': Must have length 1" @@ -166,7 +167,7 @@ test_that("nRef is taken from the LdMatrix blocks; disagreement is an error", { expect_equal(ldPanelNSamples(buildLdEigen(list(a, a))), 500L) expect_error(buildLdEigen(list(a, b)), "differing reference panel sizes") - # An explicit nRef settles it. + # An explicit nSamples settles it. expect_equal( ldPanelNSamples(buildLdEigen(list(a, b), nSamples = 700L)), 700L @@ -242,12 +243,11 @@ 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 + # The blocks 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]]) + blocks <- GenomicRanges::GRanges( + "21", + IRanges::IRanges(c(pos[[1L]], cut), c(cut - 1L, pos[[300L]])) ) ref <- buildLdScore(panel, ldBlocks = blocks) expect_equal(length(ref), 300L) @@ -263,10 +263,12 @@ test_that("a genotype panel is cut into LD blocks at ldBlocks", { unname(computeLd(panel, snpIdx = 200:300)) ) expect_error(buildLdScore(panel), "`ldBlocks` is required") - overlapping <- data.frame( - chrom = "chr21", - start = c(pos[[1L]], pos[[100L]]), - end = c(pos[[150L]], pos[[300L]]) + overlapping <- GenomicRanges::GRanges( + "chr21", + IRanges::IRanges( + c(pos[[1L]], pos[[100L]]), + c(pos[[150L]], pos[[300L]]) + ) ) expect_error( buildLdEigen(panel, ldBlocks = overlapping), @@ -280,10 +282,12 @@ test_that("a stochastic sketch's blocks carry its effective size", { test_path("test_data", "test_harmonize_regions.pgen") ) gr <- SummarizedExperiment::rowRanges(sketch) - blocks <- data.frame( - chrom = "chr21", - start = min(GenomicRanges::start(gr)), - end = max(GenomicRanges::start(gr)) + blocks <- GenomicRanges::GRanges( + "chr21", + IRanges::IRanges( + min(GenomicRanges::start(gr)), + max(GenomicRanges::start(gr)) + ) ) ref <- buildLdEigen(sketch, ldBlocks = blocks) # 50 real samples projected onto 100 pseudo-samples: 1 / (1/50 + 1/100). @@ -346,3 +350,23 @@ test_that("a block's LD and decomposition are read as stored", { 0L ) }) + +# =========================================================================== +# updateObject(): statistics saved by an earlier version +# =========================================================================== + +test_that("updateObject() renames nRef; an old statistic gets no reference", { + x <- .lds_score() + # Saved before the reference's sample size was named nSamples, and + # before a statistic could keep an LD reference at all. + saved <- .savedUnder(x, c(nRef = "nSamples")) + attr(saved, "ldReference") <- NULL + up <- updateObject(saved) + expect_true(validObject(up)) + expect_identical(up, x) + expect_identical(updateObject(x), x) + expect_message( + updateObject(x, verbose = TRUE), + "updateObject\\(object = 'LdScore'\\)" + ) +}) diff --git a/tests/testthat/test_MethodOptions.R b/tests/testthat/test_MethodOptions.R index f166208f..5c6f3b80 100644 --- a/tests/testthat/test_MethodOptions.R +++ b/tests/testthat/test_MethodOptions.R @@ -67,27 +67,17 @@ test_that(".newMethodOptions merges defaults under extras, dropping NULLs", { }) test_that(".newMethodOptions rejects a name the engine cannot accept", { - expect_error( + bad <- function() { pecotmr:::.newMethodOptions( "stats::var", defaults = list(), extra = list(naRM = TRUE), label = "varArgs" - ), - "unknown argument\\(s\\) naRM" - ) -}) - -test_that(".newMethodOptions names the engine's accepted arguments in the error", { - expect_error( - pecotmr:::.newMethodOptions( - "stats::var", - defaults = list(), - extra = list(nope = 1), - label = "varArgs" - ), - "stats::var. accepts:.*na\\.rm" - ) + ) + } + expect_error(bad(), "unknown argument\\(s\\) naRM") + # The error names the arguments the engine does accept. + expect_error(bad(), "stats::var. accepts:.*na\\.rm") }) test_that(".newMethodOptions skips validation when the engine takes dots", { diff --git a/tests/testthat/test_MethodParam.R b/tests/testthat/test_MethodParam.R index 4aa2908c..78e6b0bf 100644 --- a/tests/testthat/test_MethodParam.R +++ b/tests/testthat/test_MethodParam.R @@ -193,15 +193,31 @@ test_that("TwasWeightsMethodsParam shares the rules with its own registry", { ) expect_s4_class(p, "TwasWeightsMethodsParam") expect_equal(p$qtlDatasetMethods$lasso$nfolds, 5) - # The registries differ: prsCs is summary-statistics only, enet + # The registries differ: prsCs is summary-statistics only, dprVb # individual only, and both are methods a fine-mapping Param never has. expect_error( TwasWeightsMethodsParam(qtlDatasetMethods = list(prsCs = list())), "prsCs is not a method this pipeline runs on QtlDataset" ) expect_error( - TwasWeightsMethodsParam(qtlSumStatsMethods = list(enet = list())), - "enet is not a method this pipeline runs on QtlSumStats" + TwasWeightsMethodsParam(qtlSumStatsMethods = list(dprVb = list())), + "dprVb is not a method this pipeline runs on QtlSumStats" + ) + # enet and ridge run on both, glmnet's options on one path and the + # penalized RSS solver's on the other. + both <- TwasWeightsMethodsParam( + qtlDatasetMethods = list(enet = GlmnetOptions(), ridge = list()), + qtlSumStatsMethods = list( + enet = PenalizedRssOptions(thr = 1e-6), + ridge = list() + ) + ) + expect_s4_class(both, "TwasWeightsMethodsParam") + expect_error( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list(enet = GlmnetOptions()) + ), + "options are for QtlDataset" ) expect_error( FineMappingMethodsParam(methods = list(lasso = list())), @@ -239,29 +255,6 @@ test_that("a pipeline resolves only the slots its input class reads", { ) }) -test_that("a pipeline refuses a Param built for the other pipeline", { - expect_error( - pecotmr:::.methodsParamFor( - TwasWeightsMethodsParam(methods = "lasso"), - "QtlDataset", - "FineMappingMethodsParam", - "fineMappingPipeline" - ), - "configures a different pipeline" - ) - # Its own family passes through untouched. - p <- FineMappingMethodsParam(methods = "susie") - expect_identical( - pecotmr:::.methodsParamFor( - p, - "QtlDataset", - "FineMappingMethodsParam", - "fineMappingPipeline" - ), - p - ) -}) - test_that("an entry must be built by that method's own constructor", { skip_if_not_installed("susieR") # The input-type check cannot see this: lasso and bayesA both run on @@ -570,6 +563,15 @@ test_that("show counts an unnamed list slot and names a named one", { expect_true(any(str_detect(named, "susie"))) }) +test_that("show names a BPPARAM by its backend and worker count", { + out <- capture.output(show(CrossValidationParam())) + expect_true(any(str_detect(out, fixed("SerialParam (1 worker)")))) + two <- capture.output(show(CrossValidationParam( + BPPARAM = BiocParallel::MulticoreParam(2) + ))) + expect_true(any(str_detect(two, fixed("MulticoreParam (2 workers)")))) +}) + test_that(".paramNestedText reports a nested Param that is empty", { expect_match( as.character(pecotmr:::.paramNestedText(MashComponentParam())), @@ -587,7 +589,72 @@ test_that("$ and [[ refuse names and positions a Param does not have", { expect_error(cs[[NA_integer_]], "subscript out of bounds") }) -test_that(".assetMethodParam names the record it was handed", { +# --------------------------------------------------------------------------- +# $<- +# --------------------------------------------------------------------------- + +# Every concrete MethodParam class whose constructor builds with defaults. +.mp_defaultParams <- function() { + ns <- asNamespace("pecotmr") + classes <- names(methods::getClass("MethodParam")@subclasses) + concrete <- Filter(function(cl) !methods::getClass(cl)@virtual, classes) + built <- lapply(concrete, function(cl) { + if (!exists(cl, envir = ns, mode = "function")) { + return(NULL) + } + tryCatch(get(cl, envir = ns)(), error = function(e) NULL) + }) + names(built) <- concrete + Filter(Negate(is.null), built) +} + +test_that("$<- writing a setting back to itself changes nothing", { + # The rebuild goes through each class's own constructor, so every + # constructor must accept the values it stored -- normalised lists and + # nested records included. A round trip that is not the identity would + # mean `$<-` quietly reshapes a record. + params <- .mp_defaultParams() + expect_gt(length(params), 20L) + for (cl in names(params)) { + p <- params[[cl]] + fixed <- names(pecotmr:::.PARAM_FIXED_FIELDS[[cl]]) + for (f in setdiff(methods::slotNames(p), fixed)) { + q <- do.call(`$<-`, list(p, f, methods::slot(p, f))) + expect_identical(q, p, info = paste0(cl, "$", f)) + } + } +}) + +test_that("$<- normalises through the constructor and unsets with NULL", { + # FineMappingMethodsParam() turns a method name into its options entry; + # `$<-` stores exactly what the constructor would. + p <- FineMappingMethodsParam(methods = "susie") + p$methods <- c("susie", "susieInf") + expect_identical( + p, + FineMappingMethodsParam(methods = c("susie", "susieInf")) + ) + cs <- CredibleSetParam(medianAbsCorr = 0.5) + expect_true("medianAbsCorr" %in% names(cs)) + cs$medianAbsCorr <- NULL + expect_null(cs$medianAbsCorr) + expect_false("medianAbsCorr" %in% names(cs)) +}) + +test_that("$<- refuses unknown and fixed settings, naming why", { + cs <- CredibleSetParam() + expect_error(cs$nosuch <- 1, "is not a setting of CredibleSetParam") + expect_error( + cs$maxNumSingleEffects <- 3L, + "needs a refit. Build a new CredibleSetParam\\(\\) instead" + ) + mc <- MashComponentParam() + expect_error(mc$components <- list(), "assembles it from") + pv <- PvalMethodsParam(aspu = AspuOptions(n.perm = 5000)) + expect_error(pv$methods <- list(), "one argument per method") +}) + +test_that(".assertMethodParam names the record it was handed", { # A Param of the wrong class reports its own class, not "a bare list". expect_error( pecotmr:::.assertMethodParam( @@ -770,10 +837,18 @@ test_that(".methodsParamFor and ...ForMulti route each input shape", { .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 - ) + shadowing <- intersect(names(formals(f)), own) + if (length(shadowing) == 0L) { + return(NULL) + } + # A formal is passed as a value only through one of the .mpFunSlot + # helpers, and only if it appears in the body at all; all.names() rules + # out most closures before their call tree is walked. + syms <- all.names(body(f)) + if (!any(is_in(shadowing, syms)) || !any(is_in(names(.mpFunSlot), syms))) { + return(NULL) + } + hit <- intersect(.mpFunValueSymbols(body(f)), shadowing) if (length(hit)) hit else NULL } diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index c8790032..0a8e24b3 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -1,7 +1,5 @@ # Tests for R/MultiStudyQtlDataset.R -# === Tests migrated from test_s4Constructors.R (MultiStudyQtlDataset) === - test_that("MultiStudyQtlDataset: combines two QtlDatasets", { qd1 <- QtlDataset( studyName = "s1", @@ -45,6 +43,18 @@ test_that("MultiStudyQtlDataset: rejects unnamed qtlDatasets list", { }) +test_that("MultiStudyQtlDataset: rejects non-QtlDataset entries", { + qd <- QtlDataset( + studyName = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = .sc_makeSe()) + ) + expect_error( + MultiStudyQtlDataset(qtlDatasets = list(s1 = qd, s2 = "not a dataset")), + "must be a QtlDataset" + ) +}) + 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). @@ -161,9 +171,6 @@ test_that("sumStats(MultiStudyQtlDataset) rejects selection arguments", { # =========================================================================== # Validity branches -# -# Every construction above builds a VALID object, so the message-returning -# arms of the checks were never reached. # =========================================================================== test_that("MultiStudyQtlDataset: rejects an empty qtlDatasets list", { @@ -204,8 +211,6 @@ test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { test_that("studyName unions the individual-level and summary-only studies", { - # The sumStats arm was never taken: every collection built above carries - # only QtlDatasets, so studyName() only ever read their names. data(qtlSumStatsExample) qd <- QtlDataset( studyName = "s1", @@ -229,3 +234,76 @@ test_that("MultiStudyQtlDataset: qtlDatasets guard fires on a non-list", { test_that(".msqdConcat answers an empty list for no pieces", { expect_identical(pecotmr:::.msqdConcat(list()), list()) }) + +test_that("updateObject rebuilds a MultiStudyQtlDataset from its studies", { + data(multiStudyQtlDatasetExample) + ms <- multiStudyQtlDatasetExample + expect_equal(updateObject(ms), ms) + # A study set with no summary statistics keeps none: the NULL slot is + # read through slot(), not as the placeholder attr() would return. + expect_null(pecotmr:::.msqdSavedSumStats(ms)) + expect_null(sumStats(updateObject(ms))) + noSlot <- ms + attr(noSlot, "sumStats") <- NULL + expect_null(pecotmr:::.msqdSavedSumStats(noSlot)) + expect_message( + updateObject(ms, verbose = TRUE), + "updateObject\\(object = 'MultiStudyQtlDataset'\\)" + ) + # Saved before it became a SimpleList, the studies sat in a + # `qtlDatasets` slot, which the object still carries as an attribute. + old <- ms + attr(old, "qtlDatasets") <- rev(as.list(ms)) + expect_identical(names(updateObject(old)), rev(names(ms))) + # Its summary-statistic studies are updated along with it. + qd <- QtlDataset( + studyName = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = .sc_makeSe()) + ) + withSs <- MultiStudyQtlDataset( + qtlDatasets = list(s1 = qd), + sumStats = qtlSumStatsExample + ) + expect_s4_class(sumStats(updateObject(withSs)), "QtlSumStats") +}) + +test_that("subsetting a MultiStudyQtlDataset re-checks what is left", { + data(multiStudyQtlDatasetExample) + ms <- multiStudyQtlDatasetExample + swapped <- ms[rev(names(ms))] + expect_s4_class(swapped, "MultiStudyQtlDataset") + expect_identical(names(swapped), rev(names(ms))) + expect_error(ms[1L], "at least 2 studies") +}) + +# =========================================================================== +# show() +# =========================================================================== + +test_that("show.MultiStudyQtlDataset reports per-source study counts", { + qd1 <- .sh_makeQtlDataset(studyName = "s1") + qd2 <- .sh_makeQtlDataset(studyName = "s2") + mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) + out <- capture.output(show(mt)) + expect_true(any(grepl( + "MultiStudyQtlDataset: 2 individual-level \\+ 0 sumstats", + out + ))) + expect_true(any(grepl("Individual-level studies: s1, s2", out))) +}) + +test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { + qd <- .sh_makeQtlDataset(studyName = "s1") + ss <- QtlSumStats( + studyName = "s2", + context = "c1", + trait = "t1", + entry = list(.sh_makeQtlSumstatsGr()), + genome = "hg19", + ldReference = .sh_makeGenotypeHandle() + ) + mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd), sumStats = ss) + out <- capture.output(show(mt)) + expect_true(any(grepl("Sumstats studies: s2", out))) +}) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index 27990402..677c8936 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -1,5 +1,8 @@ context("QtlDataset internal helpers") +# The bundled genotype files the tests that read real panels open. +test_data_dir <- test_path("test_data") + # =========================================================================== # Fixture builder: a QtlDataset whose GenotypeHandle is a stub. extraction # functions are stubbed in individual tests via local_mocked_bindings. @@ -19,7 +22,7 @@ context("QtlDataset internal helpers") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = a1, A2 = a2, @@ -70,16 +73,14 @@ context("QtlDataset internal helpers") ) } -# `...` reaches QtlDataset(): mafCutoff / keepIndel / keepVariants and the -# other filters are constructor arguments, so a test configures them there -# instead of assigning into the built object's slots. +# The dataset holds data only: a test that filters passes the filter to the +# extraction (.qh_filter()), as a pipeline does. .qh_makeDataset <- function( contexts = c("brain", "liver"), n_samples = 12L, geno_cov = NULL, a1 = rep("A", 6L), - a2 = rep("G", 6L), - ... + a2 = rep("G", 6L) ) { gh <- .qh_makeHandle(n_samples = n_samples, a1 = a1, a2 = a2) pheno <- setNames( @@ -89,17 +90,19 @@ context("QtlDataset internal helpers") if (is.null(geno_cov)) { geno_cov <- matrix(numeric(0), nrow = 0, ncol = 0) } - # `...` is the genotype filter now: every caller passes only filter - # fields (mafCutoff / xvarCutoff / imissCutoff / keepVariants). QtlDataset( studyName = "study1", genotypes = gh, phenotypes = pheno, - genotypeCovariates = geno_cov, - genotypeFilterParam = GenotypeFilterParam(...) + genotypeCovariates = geno_cov ) } +# A resolved genotype filter, the form a pipeline threads to each extraction. +.qh_filter <- function(...) { + pecotmr:::.qtlResolveFilter(GenotypeFilterParam(...)) +} + # =========================================================================== # .qtlResidualizeQr — pure linear algebra # =========================================================================== @@ -271,7 +274,7 @@ test_that(".qtlResolveVariantRegion: region must be a GRanges; multi-range is al qd <- .qh_makeDataset() expect_error( pecotmr:::.qtlResolveVariantRegion(qd, region = "chr1:100-200"), - "Must inherit from class 'GRanges'" + "`region` must be a GRanges" ) expect_error( pecotmr:::.qtlResolveVariantRegion( @@ -320,13 +323,15 @@ test_that(".qtlVariantIndices: filters by chromosome and BP range", { expect_equal(idx, c(2L, 3L)) }) -test_that(".qtlVariantIndices: accepts chr-prefixed and bare chromosome names", { +test_that(".qtlVariantIndices: a bare-named region is read as UCSC", { qd <- .qh_makeDataset() r1 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(50, 250)) r2 <- GenomicRanges::GRanges("1", IRanges::IRanges(50, 250)) + idx <- pecotmr:::.qtlVariantIndices(qd, r1) + expect_gt(length(idx), 0L) expect_equal( - pecotmr:::.qtlVariantIndices(qd, r1), - pecotmr:::.qtlVariantIndices(qd, r2) + pecotmr:::.qtlVariantIndices(qd, pecotmr:::.qtlLiteralRegion(r2, NULL)), + idx ) }) @@ -352,16 +357,19 @@ test_that("traitPosition returns each trait's union genomic span across contexts expect_equal(GenomicRanges::end(gr["ENSG1"]), 1499L) # start 1000 + width 500 - 1 expect_equal(GenomicRanges::start(gr["ENSG2"]), 2000L) # single-trait selection routes through the traitId branch of the method - one <- traitPosition(qd, traitId = "ENSG2") + one <- traitPosition(qd, trait = "ENSG2") expect_equal(names(one), "ENSG2") expect_equal(GenomicRanges::start(one), 2000L) }) -test_that("traitPosition emits a chrUn sentinel for a trait absent from every context", { +test_that("traitPosition refuses a trait absent from every context", { + # No placeholder range: an unknown name is an error, as it is for + # rowRanges(), naming every trait that is missing. qd <- .qh_makeDataset(contexts = "brain") - gr <- traitPosition(qd, traitId = "NOPE") - expect_equal(names(gr), "NOPE") - expect_equal(as.character(GenomicRanges::seqnames(gr)), "chrUn") + expect_error( + traitPosition(qd, trait = c("NOPE", "ALSO")), + "in no context of this QtlDataset: NOPE, ALSO" + ) }) # (QtlDataset validity requires a trait's rowRanges to be identical across @@ -369,39 +377,40 @@ test_that("traitPosition emits a chrUn sentinel for a trait absent from every co # matching ranges; the two-context fixture above already exercises that loop.) # =========================================================================== -# .qtlApplyFilterOverrides +# .qtlResolveFilter: a run's genotype filter # =========================================================================== -test_that(".qtlApplyFilterOverrides replaces every supplied slot on a validated copy", { +test_that(".qtlResolveFilter carries every set field; keepSamples narrows", { qd <- .qh_makeDataset(contexts = "brain") - out <- pecotmr:::.qtlApplyFilterOverrides( - qd, - GenotypeFilterParam( - mafCutoff = 0.05, - macCutoff = 10, - xvarCutoff = 0.01, - imissCutoff = 0.1, - keepIndel = FALSE, - keepSamples = c("s1", "s2"), - keepVariants = c("rs1", "rs2") - ) - ) - expect_equal(out@mafCutoff, 0.05) - expect_equal(out@macCutoff, 10) - expect_equal(out@xvarCutoff, 0.01) - expect_equal(out@imissCutoff, 0.1) - expect_false(out@keepIndel) + filt <- .qh_filter( + mafCutoff = 0.05, + macCutoff = 10, + xvarCutoff = 0.01, + imissCutoff = 0.1, + keepIndel = FALSE, + keepSamples = c("s1", "s2"), + keepVariants = c("rs1", "rs2") + ) + expect_equal(filt$mafCutoff, 0.05) + expect_equal(filt$macCutoff, 10) + expect_equal(filt$xvarCutoff, 0.01) + expect_equal(filt$imissCutoff, 0.1) + expect_false(filt$keepIndel) + expect_equal(filt$keepVariants, c("rs1", "rs2")) + out <- pecotmr:::.qtlRestrictSamples(qd, filt$keepSamples) expect_setequal( rownames(MultiAssayExperiment::colData(out)), c("s1", "s2") ) - expect_equal(out@keepVariants, c("rs1", "rs2")) }) -test_that(".qtlApplyFilterOverrides leaves stored slots untouched when args are NULL", { +test_that("an unset filter filters nothing and leaves the dataset whole", { qd <- .qh_makeDataset(contexts = "brain") + filt <- .qh_filter() + expect_equal(filt$mafCutoff, 0) + expect_true(filt$keepIndel) expect_identical( - pecotmr:::.qtlApplyFilterOverrides(qd, GenotypeFilterParam()), + pecotmr:::.qtlRestrictSamples(qd, filt$keepSamples), qd ) }) @@ -476,7 +485,7 @@ test_that(".qtlResolvePhenoSelection: list with extra keys errors", { contexts = "brain", toResidualize = list(brain = "age", ghost = "sex") ), - "list key.*not in `contexts`" + "list key.*not in `context`" ) }) @@ -714,6 +723,24 @@ test_that(".qtlBuildResidualizationDesign: intersects sample sets across blocks" } } +test_that(".qtlExtractBlock refuses a missing filter rather than skip it", { + # A pipeline threads its resolved filter to every extraction; NULL means + # a call site dropped it, which must not pass for "no filter". + qd <- .qh_makeDataset() + expect_error( + pecotmr:::.qtlExtractBlock(qd, filter = NULL), + "No resolved genotype filter" + ) +}) + +test_that("a NULL residualization bundle scales, as an unset field does", { + expect_true(pecotmr:::.qtlScaleResiduals(NULL)) + expect_true(pecotmr:::.qtlScaleResiduals(ResidualizationParam())) + expect_false(pecotmr:::.qtlScaleResiduals( + ResidualizationParam(scaleResiduals = FALSE) + )) +}) + test_that(".qtlExtractBlock: returns dosage matrix with kept variants and samples", { qd <- .qh_makeDataset() local_mocked_bindings( @@ -731,27 +758,27 @@ test_that(".qtlExtractBlock: returns dosage matrix with kept variants and sample test_that(".qtlExtractBlock: empty snpIdx returns a zero-column block", { qd <- .qh_makeDataset() region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 1000)) - blk <- pecotmr:::.qtlExtractBlock(qd, region = region) + blk <- pecotmr:::.qtlExtractBlock(qd, window = region) expect_equal(ncol(blk$geno), 0L) expect_equal(blk$variantIds, character(0)) }) test_that(".qtlExtractBlock: keepVariants restriction narrows the returned set", { - qd <- .qh_makeDataset(keepVariants = c("rs2", "rs4")) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(keepVariants = c("rs2", "rs4")) + ) expect_setequal(blk$variantIds, c("rs2", "rs4")) }) test_that(".qtlExtractBlock: keepSamples restriction narrows the returned set", { qd <- .qh_makeDataset() - qd <- pecotmr:::.qtlApplyFilterOverrides( - qd, - GenotypeFilterParam(keepSamples = paste0("s", 1:6)) - ) + qd <- pecotmr:::.qtlRestrictSamples(qd, paste0("s", 1:6)) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" @@ -762,10 +789,7 @@ test_that(".qtlExtractBlock: keepSamples restriction narrows the returned set", test_that(".qtlExtractBlock: per-call samples arg further narrows the sample set", { qd <- .qh_makeDataset() - qd <- pecotmr:::.qtlApplyFilterOverrides( - qd, - GenotypeFilterParam(keepSamples = paste0("s", 1:6)) - ) + qd <- pecotmr:::.qtlRestrictSamples(qd, paste0("s", 1:6)) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" @@ -775,12 +799,15 @@ test_that(".qtlExtractBlock: per-call samples arg further narrows the sample set }) test_that(".qtlExtractBlock: keepVariants with empty intersection returns empty block", { - qd <- .qh_makeDataset(keepVariants = c("rsGHOST")) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(keepVariants = "rsGHOST") + ) expect_equal(ncol(blk$geno), 0L) expect_equal(nrow(blk$geno), 0L) }) @@ -789,20 +816,21 @@ test_that(".qtlExtractBlock: keepIndel = FALSE drops multi-base (indel) variants # rs2 an insertion, rs4 a deletion; the rest stay SNPs. qd <- .qh_makeDataset( a1 = replace(rep("A", 6L), 2L, "AT"), - a2 = replace(rep("G", 6L), 4L, "GC"), - keepIndel = FALSE + a2 = replace(rep("G", 6L), 4L, "GC") ) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(keepIndel = FALSE) + ) expect_equal(blk$variantIds, c("rs1", "rs3", "rs5", "rs6")) }) test_that(".qtlExtractBlock: keepIndel = TRUE (default) keeps indel variants", { qd <- .qh_makeDataset(a1 = replace(rep("A", 6L), 2L, "AT")) - expect_true(qd@keepIndel) # default local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" @@ -811,35 +839,33 @@ test_that(".qtlExtractBlock: keepIndel = TRUE (default) keeps indel variants", { expect_equal(length(blk$variantIds), 6L) }) -test_that("QtlDataset: keepIndel defaults to TRUE; validity rejects non-scalar", { - qd <- .qh_makeDataset() - expect_true(qd@keepIndel) - # The constructor coerces via isTRUE(); validity guards direct new()/slot sets. - qd@keepIndel <- c(TRUE, FALSE) - expect_error(validObject(qd), "Variable 'keepIndel'") +test_that("keepIndel resolves to TRUE and must be a flag", { + expect_true(.qh_filter()$keepIndel) + expect_error(GenotypeFilterParam(keepIndel = c(TRUE, FALSE)), "keepIndel") + expect_error(GenotypeFilterParam(keepIndel = NA), "keepIndel") }) test_that(".qtlExtractBlock: mafCutoff drops low-MAF variants", { # The mocked extractor returns binomial(0.3) dosages: realized MAFs hover # around 0.3-0.5 (small sample noise). Cutoff above the realized maximum # drops everything. - qd <- .qh_makeDataset(mafCutoff = 0.51) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock(qd, filter = .qh_filter(mafCutoff = 0.51)) expect_equal(ncol(blk$geno), 0L) }) test_that(".qtlExtractBlock: mafCutoff retains variants above the threshold", { # realized MAFs include 0.458 and 0.5 - qd <- .qh_makeDataset(mafCutoff = 0.4) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock(qd, filter = .qh_filter(mafCutoff = 0.4)) expect_true(ncol(blk$geno) >= 1L) expect_true(all(blk$maf >= 0.4)) }) @@ -927,8 +953,8 @@ test_that("maf stays folded while af is directional (they fold into each other)" context("QtlDataset residualization methods") # =========================================================================== -# Fixture: mirrors test_qtlDatasetHelpers.R so we can mock extractBlockGenotypes -# the same way. +# Fixture: mirrors the .qh_* builders above so extractBlockGenotypes can be +# mocked the same way. # =========================================================================== .qr_makeHandle <- function(snp_n = 6L, n_samples = 12L) { @@ -938,7 +964,7 @@ context("QtlDataset residualization methods") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -988,8 +1014,7 @@ context("QtlDataset residualization methods") .qr_makeDataset <- function( contexts = c("brain", "liver"), n_samples = 12L, - geno_cov = NULL, - scaleResiduals = TRUE + geno_cov = NULL ) { gh <- .qr_makeHandle(n_samples = n_samples) pheno <- setNames( @@ -1003,8 +1028,7 @@ context("QtlDataset residualization methods") studyName = "study1", genotypes = gh, phenotypes = pheno, - genotypeCovariates = geno_cov, - scaleResiduals = scaleResiduals + genotypeCovariates = geno_cov ) } @@ -1045,15 +1069,12 @@ context("QtlDataset residualization methods") } } -# =========================================================================== # =========================================================================== # Residualization flags (NULL = unset) +# +# ResidualizationParam() defaults each flag to NULL, so "not given" is +# representable apart from FALSE and the accessors just read the field. # =========================================================================== -# .qtlResolveResidualizationFlag and its two `*Flags` callers are gone: the -# convenience/precise pair of booleans plus a missing() companion for each -# existed only because a flat formal defaulting to TRUE cannot tell FALSE -# from "not given". ResidualizationParam() defaults them to NULL, so -# absence is representable and the accessors just read the field. test_that("an unset residualization flag means the side is residualized", { cfg <- ResidualizationParam() @@ -1134,21 +1155,21 @@ test_that(".qtlHandleCovariateNa: drop removes any sample with a missing covaria test_that("residualizedGenotypes: requires contexts", { qd <- .qr_makeDataset() - expect_error(residualizedGenotypes(qd), "`contexts` is required") + expect_error(residualizedGenotypes(qd), "`context` is required") expect_error( - residualizedGenotypes(qd, contexts = NULL), - "`contexts` is required" + residualizedGenotypes(qd, context = NULL), + "`context` is required" ) expect_error( - residualizedGenotypes(qd, contexts = character(0)), - "`contexts` is required" + residualizedGenotypes(qd, context = character(0)), + "`context` is required" ) }) test_that("residualizedGenotypes: unknown context errors", { qd <- .qr_makeDataset() expect_error( - residualizedGenotypes(qd, contexts = "ghost"), + residualizedGenotypes(qd, context = "ghost"), "Unknown context" ) }) @@ -1161,7 +1182,11 @@ test_that("residualizedGenotypes: empty genotype block short-circuits to G", { ) # region with no SNPs in the panel. region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 1000)) - G <- residualizedGenotypes(qd, contexts = "brain", region = region) + G <- pecotmr:::.qtlResidualizedGenotypes( + qd, + contexts = "brain", + window = region + ) expect_equal(ncol(G), 0L) }) @@ -1171,7 +1196,7 @@ test_that("residualizedGenotypes: produces residualized matrix shape", { extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- residualizedGenotypes(qd, contexts = "brain") + G <- residualizedGenotypes(qd, context = "brain") expect_equal(nrow(G), 12L) expect_equal(ncol(G), 6L) # When scaleResiduals = TRUE (the default), kept columns should have unit sd @@ -1189,7 +1214,7 @@ test_that("residualizedGenotypes: residualizes only against selected pheno covar ) G <- residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam(phenotypeCovariates = "age") ) expect_equal(nrow(G), 12L) @@ -1210,7 +1235,7 @@ test_that("residualizedGenotypes: respects residualizePhenotype = FALSE", { # is just the centered (and scaled) raw block. G1 <- residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) @@ -1219,41 +1244,12 @@ test_that("residualizedGenotypes: respects residualizePhenotype = FALSE", { expect_equal(ncol(G1), 6L) }) -test_that("residualizedGenotypes: precise-name kwarg routes correctly", { - qd <- .qr_makeDataset(contexts = "brain") - local_mocked_bindings( - extractBlockGenotypes = .qr_mockExtractor(), - .package = "pecotmr" - ) - G_precise <- residualizedGenotypes( - qd, - contexts = "brain", - residualizationParam = ResidualizationParam( - residualizePhenotype = FALSE - ) - ) - G_conv <- residualizedGenotypes( - qd, - contexts = "brain", - residualizationParam = ResidualizationParam( - residualizePhenotype = FALSE - ) - ) - expect_equal(G_precise, G_conv) -}) - -# The convenience/precise conflict test is gone with the duality itself: -# residualizePhenotypeCovariates and its FromGenotypes twin were two -# spellings of one -# boolean, needing a conflict check between them. ResidualizationParam() -# has one field, so there is nothing left to conflict. - test_that("residualizedGenotypes refuses a bare list for the bundle", { qd <- .qr_makeDataset(contexts = "brain") expect_error( residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = list(residualizePhenotype = FALSE) ), "ResidualizationParam" @@ -1266,7 +1262,7 @@ test_that("residualizedGenotypes: joint-context mode intersects samples", { extractBlockGenotypes = .qr_mockExtractor(), .package = "pecotmr" ) - G <- residualizedGenotypes(qd, contexts = c("brain", "liver")) + G <- residualizedGenotypes(qd, context = c("brain", "liver")) expect_equal(nrow(G), 12L) expect_setequal(rownames(G), paste0("s", 1:12)) }) @@ -1285,7 +1281,7 @@ test_that("residualizedGenotypes: includes genotype covariates when supplied", { ) G <- residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2") ) @@ -1313,7 +1309,7 @@ test_that("residualizedGenotypes: mean-imputes missing covariates by default", { # Default covariateNaAction = "impute": no error, all 12 samples retained. G <- residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2") ) @@ -1337,7 +1333,7 @@ test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with ) G <- residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( genotypeCovariates = c("pc1", "pc2"), covariateNaAction = "drop" @@ -1353,33 +1349,45 @@ test_that("residualizedGenotypes: covariateNaAction='drop' removes samples with test_that("residualizedPhenotypes: requires contexts", { qd <- .qr_makeDataset() - expect_error(residualizedPhenotypes(qd), "`contexts` is required") + expect_error(residualizedPhenotypes(qd), "`context` is required") }) test_that("residualizedPhenotypes: unknown context errors", { qd <- .qr_makeDataset() expect_error( - residualizedPhenotypes(qd, contexts = "ghost"), + residualizedPhenotypes(qd, context = "ghost"), "Unknown context" ) }) test_that("residualizedPhenotypes: returns one matrix per context", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) - res <- residualizedPhenotypes(qd, contexts = c("brain", "liver")) + res <- residualizedPhenotypes(qd, context = c("brain", "liver")) expect_equal(names(res), c("brain", "liver")) expect_equal(nrow(res$brain), 12L) expect_equal(ncol(res$brain), 2L) expect_equal(nrow(res$liver), 12L) }) +test_that("residualizedPhenotypes: an absent trait gives zero columns", { + # The trait filter keeps none of brain's traits; residualizing that empty + # selection answers an empty matrix rather than failing inside lm.fit(). + qd <- .qr_makeDataset() + expect_warning( + res <- residualizedPhenotypes(qd, context = "brain", trait = "absent"), + "context 'brain' is missing trait(s): absent", + fixed = TRUE + ) + expect_equal(dim(res$brain), c(12L, 0L)) +}) + test_that("residualizedPhenotypes: residualizes against age covariate", { qd <- .qr_makeDataset(contexts = "brain") Y <- residualizedPhenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam(phenotypeCovariates = "age") - ) + )[["brain"]] age <- seq_len(12) for (j in seq_len(ncol(Y))) { expect_lt(abs(cor(Y[, j], age)), 1e-6) @@ -1390,53 +1398,50 @@ test_that("residualizedPhenotypes: respects residualizePhenotype = FALSE", { qd <- .qr_makeDataset(contexts = "brain") Y <- residualizedPhenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( residualizePhenotype = FALSE ) - ) + )[["brain"]] expect_equal(nrow(Y), 12L) expect_equal(ncol(Y), 2L) }) -test_that("residualizedPhenotypes: precise-name kwarg routes correctly", { +test_that("residualizedPhenotypes: trait subsets to requested traits", { qd <- .qr_makeDataset(contexts = "brain") - Y_precise <- residualizedPhenotypes( - qd, - contexts = "brain", - residualizationParam = ResidualizationParam( - residualizePhenotype = FALSE - ) - ) - Y_conv <- residualizedPhenotypes( - qd, - contexts = "brain", - residualizationParam = ResidualizationParam( - residualizePhenotype = FALSE - ) - ) - expect_equal(Y_precise, Y_conv) -}) - -test_that("residualizedPhenotypes: traitId subsets to requested traits", { - qd <- .qr_makeDataset(contexts = "brain") - Y <- residualizedPhenotypes(qd, contexts = "brain", traitId = "ENSG1") + Y <- residualizedPhenotypes(qd, context = "brain", trait = "ENSG1")[[ + "brain" + ]] expect_equal(ncol(Y), 1L) expect_equal(colnames(Y), "ENSG1") }) test_that("residualizedPhenotypes: scaleResiduals = FALSE skips the rescale step", { - qd <- .qr_makeDataset(contexts = "brain", scaleResiduals = FALSE) - Y <- residualizedPhenotypes(qd, contexts = "brain") + qd <- .qr_makeDataset(contexts = "brain") + Y <- residualizedPhenotypes( + qd, + context = "brain", + residualizationParam = ResidualizationParam(scaleResiduals = FALSE) + )[["brain"]] # Without scaling the residual columns generally won't have sd = 1. sds <- apply(Y, 2L, sd) expect_false(any(abs(sds - 1) < 1e-6)) }) # =========================================================================== -# molecularTraits/residualizedPhenotypes naAction +# Phenotype QC (PhenotypeFilterParam) applied by the extraction workers # =========================================================================== +# The run's resolved phenotype QC, as a pipeline hands it to the workers. +.qr_pheno <- function(...) { + pecotmr:::.qtlResolvePhenotypeFilter( + PhenotypeFilterParam(...), + naDefault = "keep", + naAllowed = c("keep", "drop", "impute"), + caller = "test" + ) +} + # Helper to build a single-context SE with controlled NA placement. .qr_makeSeWithNa <- function(n_samples = 8L, na_idx = c(2L, 5L)) { traits <- c("ENSG1", "ENSG2") @@ -1465,7 +1470,7 @@ test_that("residualizedPhenotypes: scaleResiduals = FALSE skips the rescale step ) } -test_that("molecularTraits naAction='drop' drops samples with any NA in selected traits", { +test_that("naAction = 'drop' drops samples with an NA in a selected trait", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( @@ -1474,13 +1479,17 @@ test_that("molecularTraits naAction='drop' drops samples with any NA in selected phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- molecularTraits(qd, contexts = "brain", naAction = "drop") + out <- pecotmr:::.qtlMolecularTraits( + qd, + "brain", + phenotypeFilter = .qr_pheno(naAction = "drop") + )[["brain"]] expect_s4_class(out, "SummarizedExperiment") expect_equal(ncol(out), 6L) expect_false(any(is.na(SummarizedExperiment::assay(out)))) }) -test_that("molecularTraits naAction='impute' mean-imputes NAs per trait", { +test_that("naAction = 'impute' mean-imputes NAs per trait", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( @@ -1489,7 +1498,11 @@ test_that("molecularTraits naAction='impute' mean-imputes NAs per trait", { phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- molecularTraits(qd, contexts = "brain", naAction = "impute") + out <- pecotmr:::.qtlMolecularTraits( + qd, + "brain", + phenotypeFilter = .qr_pheno(naAction = "impute") + )[["brain"]] Y <- SummarizedExperiment::assay(out) expect_equal(ncol(Y), 8L) expect_false(any(is.na(Y))) @@ -1500,7 +1513,7 @@ test_that("molecularTraits naAction='impute' mean-imputes NAs per trait", { expect_equal(Y[1L, 5L], obsMean) }) -test_that("residualizedPhenotypes naAction='impute' yields NA-free residuals", { +test_that("residualizing under naAction = 'impute' yields NA-free residuals", { gh <- .qr_makeHandle(n_samples = 8L) se <- .qr_makeSeWithNa(n_samples = 8L, na_idx = c(2L, 5L)) qd <- QtlDataset( @@ -1509,13 +1522,17 @@ test_that("residualizedPhenotypes naAction='impute' yields NA-free residuals", { phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - Y <- residualizedPhenotypes(qd, contexts = "brain", naAction = "impute") + Y <- pecotmr:::.qtlResidualizedPhenotypes( + qd, + "brain", + phenotypeFilter = .qr_pheno(naAction = "impute") + )[["brain"]] expect_false(any(is.na(Y))) expect_equal(nrow(Y), 8L) }) # =========================================================================== -# molecularTraits/residualizedPhenotypes outlierAction +# Outliers: dropped under the run's QC, kept by the accessors # =========================================================================== # Build a single-context SE with a clear multivariate outlier at sample s10. @@ -1551,7 +1568,7 @@ test_that("residualizedPhenotypes naAction='impute' yields NA-free residuals", { ) } -test_that("molecularTraits outlierAction='drop' drops a clear multivariate outlier", { +test_that("outlierAction = 'drop' drops a clear multivariate outlier", { skip_if_not_installed("robustbase") gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) @@ -1561,13 +1578,17 @@ test_that("molecularTraits outlierAction='drop' drops a clear multivariate outli phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- molecularTraits(qd, contexts = "brain", outlierAction = "drop") + out <- pecotmr:::.qtlMolecularTraits( + qd, + "brain", + phenotypeFilter = .qr_pheno(outlierAction = "drop") + )[["brain"]] expect_s4_class(out, "SummarizedExperiment") expect_lt(ncol(out), 30L) expect_false("s10" %in% colnames(out)) }) -test_that("molecularTraits outlierAction='keep' is the default and a no-op", { +test_that("the accessors apply no phenotype QC: an outlier stays", { gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) qd <- QtlDataset( @@ -1576,11 +1597,20 @@ test_that("molecularTraits outlierAction='keep' is the default and a no-op", { phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - out <- molecularTraits(qd, contexts = "brain") + out <- molecularTraits(qd, context = "brain")[["brain"]] expect_equal(ncol(out), 30L) + # QC belongs to the run, so the accessors take none of its settings. + expect_error( + molecularTraits(qd, context = "brain", outlierAction = "drop"), + "unused argument" + ) + expect_error( + residualizedPhenotypes(qd, context = "brain", naAction = "drop"), + "unused argument" + ) }) -test_that("residualizedPhenotypes outlierAction='drop' drops residualized outliers", { +test_that("outlierAction = 'drop' drops residualized outliers", { skip_if_not_installed("robustbase") gh <- .qr_makeHandle(n_samples = 30L) se <- .qr_makeSeWithOutlier(n_samples = 30L, outlier_idx = 10L) @@ -1590,11 +1620,11 @@ test_that("residualizedPhenotypes outlierAction='drop' drops residualized outlie phenotypes = list(brain = se), genotypeCovariates = matrix(numeric(0), 0L, 0L) ) - Y <- residualizedPhenotypes( + Y <- pecotmr:::.qtlResidualizedPhenotypes( qd, - contexts = "brain", - outlierAction = "drop" - ) + "brain", + phenotypeFilter = .qr_pheno(outlierAction = "drop") + )[["brain"]] expect_lt(nrow(Y), 30L) expect_false("s10" %in% rownames(Y)) }) @@ -1620,355 +1650,9 @@ test_that(".qtlOutlierKeepMask: returns all-TRUE when n < p + 2", { expect_true(all(keep)) }) - -# Tests for functions that consume genotype matrices or compute LD: -# computeLd, checkLd, ldPruneByCorrelation, ldClumpByScore, -# enforceDesignFullRank, filterVariantsByLdReference, -# resolveLdInput, dentistSingleWindow, dentist - -# Fixtures: 100 samples x 100 biallelic polymorphic SNPs on chr21 -test_data_dir <- test_path("test_data") -plink_prefix <- file.path(test_data_dir, "test_variants") - -# Load genotype matrix once for reuse across tests -loadTestGenotype <- function() { - loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) -} - -# --- computeLd -------------------------------------------------------------- - -test_that("computeLd produces valid sample correlation matrix", { - skip_if_not_installed("pgenlibr") - geno <- loadTestGenotype() - R <- computeLd(geno$X, method = "sample") - expect_true(is.matrix(R)) - expect_equal(nrow(R), ncol(geno$X)) - expect_equal(ncol(R), ncol(geno$X)) - expect_true(isSymmetric(R)) - expect_true(all(abs(diag(R) - 1) < 1e-10)) - expect_false(any(is.nan(R))) - expect_true(all(R >= -1 - 1e-10 & R <= 1 + 1e-10)) -}) - -test_that("computeLd population method produces valid matrix", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "population") - expect_true(isSymmetric(R)) - expect_true(all(abs(diag(R) - 1) < 1e-10)) - expect_false(any(is.nan(R))) -}) - -test_that("computeLd sample and population methods are similar", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R_s <- computeLd(X, method = "sample") - R_p <- computeLd(X, method = "population") - # Should be close but not identical (N-1 vs N denominator) - expect_true(max(abs(R_s - R_p)) < 0.05) -}) - -test_that("computeLd errors on NULL input", { - expect_error(computeLd(NULL), "X must be provided") -}) - -# --- checkLd ---------------------------------------------------------------- - -test_that("checkLd diagnoses real LD matrix correctly", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - result <- checkLd(R) - expect_true(is.list(result)) - expect_true(result$isPsd) - expect_equal(result$methodApplied, "none") - # min eigenvalue may be near-zero (numerically PSD, not strictly PD) - expect_true(result$minEigenvalue > -1e-7) - expect_true(result$nNegative == 0) - expect_true(is.finite(result$conditionNumber)) -}) - -test_that("checkLd eigenfix improves non-PSD matrix", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - # Make a non-PSD matrix by negating a small block of off-diagonal entries - R_bad <- R - R_bad[1:3, 4:6] <- -abs(R_bad[1:3, 4:6]) - 0.5 - R_bad[4:6, 1:3] <- t(R_bad[1:3, 4:6]) - diag(R_bad) <- 1 - - result_check <- checkLd(R_bad, method = "check") - expect_false(result_check$isPsd) - expect_true(result_check$nNegative > 0) - - result_fix <- checkLd(R_bad, method = "eigenfix") - expect_equal(result_fix$methodApplied, "eigenfix") - # Eigenfix should improve (raise) minimum eigenvalue - fixed_check <- checkLd(result_fix$R) - expect_true(fixed_check$minEigenvalue > result_check$minEigenvalue) -}) - -test_that("checkLd shrink repairs perturbed LD matrix", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - R_bad <- R - R_bad[1, 2] <- R_bad[2, 1] <- 1.5 - diag(R_bad) <- 1 - result <- checkLd(R_bad, method = "shrink", shrinkage = 0.1) - expect_equal(result$methodApplied, "shrink") -}) - -# --- ldPruneByCorrelation ------------------------------------------------- - -test_that("ldPruneByCorrelation prunes correlated variants", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - result <- ldPruneByCorrelation(X, corThres = 0.8) - expect_true(is.list(result)) - expect_true(is.matrix(result$X.new)) - expect_true(ncol(result$X.new) <= ncol(X)) - expect_true(ncol(result$X.new) > 0) - expect_equal(length(result$filter.id), ncol(result$X.new)) - # Retained columns are a subset of original - expect_true(all(result$filter.id %in% seq_len(ncol(X)))) -}) - -test_that("ldPruneByCorrelation with strict threshold prunes more", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - loose <- ldPruneByCorrelation(X, corThres = 0.95) - strict <- ldPruneByCorrelation(X, corThres = 0.5) - expect_true(ncol(strict$X.new) <= ncol(loose$X.new)) -}) - -test_that("ldPruneByCorrelation with high threshold keeps most columns", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - result <- ldPruneByCorrelation(X, corThres = 0.999) - # At threshold near 1, only near-duplicates are pruned; real data may have many - expect_true(ncol(result$X.new) >= ncol(X) * 0.4) -}) - -# --- ldClumpByScore ------------------------------------------------------- - -test_that("ldClumpByScore returns valid indices", { - skip_if_not_installed("pgenlibr") - skip_if_not_installed("bigsnpr") - skip_if_not_installed("bigstatsr") - geno <- loadTestGenotype() - set.seed(42) - score <- runif(ncol(geno$X)) - chr <- as.integer(geno$variant_info$chrom) - pos <- geno$variant_info$pos - keep <- ldClumpByScore( - geno$X, - score = score, - chr = chr, - pos = pos, - r2 = 0.2 - ) - expect_true(is.integer(keep)) - expect_true(length(keep) > 0) - expect_true(length(keep) <= ncol(geno$X)) - expect_true(all(keep %in% seq_len(ncol(geno$X)))) -}) - -# --- enforceDesignFullRank ------------------------------------------------ - -test_that("enforceDesignFullRank handles genotype matrix with covariates", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - # Create a simple covariate matrix (e.g., first 2 PCs of X) - pca <- prcomp(X, rank. = 2) - C <- pca$x - result <- enforceDesignFullRank(X, C, strategy = "correlation") - expect_true(is.matrix(result)) - expect_equal(nrow(result), nrow(X)) - # Should produce full-rank design - full_design <- cbind(1, result, C) - expect_equal(qr(full_design)$rank, ncol(full_design)) -}) - -# --- filterVariantsByLdReference ----------------------------------------- - -test_that("filterVariantsByLdReference filters against PLINK reference via metadata", { - skip_if_not_installed("pgenlibr") - geno <- loadTestGenotype() - vi <- geno$variant_info - variant_ids <- paste0(vi$chrom, ":", vi$pos, ":", vi$A2, ":", vi$A1) - fake_ids <- c("21:999999:A:G", "21:888888:C:T") - all_ids <- c(variant_ids, fake_ids) - - # Create a metadata TSV in the same directory as the PLINK files - # so the relative path resolves correctly - meta_file <- file.path(test_data_dir, "ld_meta_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 <- suppressMessages( - filterVariantsByLdReference(all_ids, meta_file, keepIndel = TRUE) - ) - expect_true(is.list(result)) - expect_true(length(result$data) <= length(all_ids)) - expect_true(length(result$idx) == length(result$data)) - # Fake variants should be filtered out - expect_true(length(result$data) <= length(variant_ids)) -}) - -# --- resolveLdInput (internal) --------------------------------------------- - -test_that("resolveLdInput computes LD from genotype matrix", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - result <- pecotmr:::resolveLdInput(X = X, needNSample = TRUE) - expect_true(is.list(result)) - expect_true(is.matrix(result$R)) - expect_equal(nrow(result$R), ncol(X)) - expect_equal(result$nSample, nrow(X)) - expect_true(isSymmetric(result$R)) -}) - -test_that("resolveLdInput passes through pre-computed R", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - result <- pecotmr:::resolveLdInput( - R = R, - nSample = 100L, - needNSample = TRUE - ) - expect_equal(result$R, R) - expect_equal(result$nSample, 100L) -}) - -test_that("resolveLdInput errors when neither R nor X provided", { - expect_error( - pecotmr:::resolveLdInput(), - "Either R .* or X .* must be provided" - ) -}) - -test_that("resolveLdInput errors when both R and X provided", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - expect_error( - pecotmr:::resolveLdInput(R = R, X = X), - "Provide either R or X, not both" - ) -}) - -test_that("resolveLdInput errors when R given without nSample and needed", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - expect_error( - pecotmr:::resolveLdInput(R = R, needNSample = TRUE), - "nSample is required" - ) -}) - -# --- dentistSingleWindow --------------------------------------------------- - -test_that("dentistSingleWindow works with genotype matrix X", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - set.seed(42) - z <- rnorm(ncol(X)) - result <- suppressWarnings(dentistSingleWindow(z, X = X)) - expect_true(is.data.frame(result)) - expect_equal(nrow(result), length(z)) - expect_true("original_z" %in% names(result)) - expect_true("imputed_z" %in% names(result)) - expect_true("outlier" %in% names(result)) - expect_true(is.logical(result$outlier)) -}) - -test_that("dentistSingleWindow works with pre-computed R", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - set.seed(42) - z <- rnorm(ncol(X)) - result <- suppressWarnings(dentistSingleWindow(z, R = R, nSample = nrow(X))) - expect_true(is.data.frame(result)) - expect_equal(nrow(result), length(z)) -}) - -test_that("dentistSingleWindow detects injected outliers", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - R <- computeLd(X, method = "sample") - set.seed(42) - z <- rnorm(ncol(X)) - # Inject extreme outliers - z[1] <- 50 - z[2] <- -50 - result <- suppressWarnings(dentistSingleWindow(z, R = R, nSample = nrow(X))) - # At least one of the injected values should be flagged - expect_true(any(result$outlier)) -}) - -# --- dentist (multi-window) ------------------------------------------------- - -test_that("dentist works with genotype matrix and sum_stat data frame", { - skip_if_not_installed("pgenlibr") - geno <- loadTestGenotype() - set.seed(42) - sum_stat <- data.frame( - pos = geno$variant_info$pos, - z = rnorm(ncol(geno$X)) - ) - # Use count mode with small window since we only have 100 variants - result <- suppressWarnings( - dentist(sum_stat, X = geno$X, windowMode = "count", minDim = 50) - ) - expect_true(is.data.frame(result)) - # Window merging may add overlap rows; result should be >= input size - expect_true(nrow(result) >= nrow(sum_stat)) - expect_true(all(c("original_z", "imputed_z", "outlier") %in% names(result))) -}) - -test_that("dentist accepts zscore column name variant", { - skip_if_not_installed("pgenlibr") - geno <- loadTestGenotype() - R <- computeLd(geno$X, method = "sample") - set.seed(42) - sum_stat <- data.frame( - position = geno$variant_info$pos, - zscore = rnorm(ncol(geno$X)) - ) - result <- suppressWarnings( - dentist( - sum_stat, - R = R, - nSample = nrow(geno$X), - windowMode = "count", - minDim = 50 - ) - ) - expect_true(nrow(result) >= nrow(sum_stat)) -}) - -test_that("dentist errors when sum_stat missing required columns", { - skip_if_not_installed("pgenlibr") - X <- loadTestGenotype()$X - bad_stat <- data.frame(x = seq_len(ncol(X)), y = rnorm(ncol(X))) - expect_error(dentist(bad_stat, X = X), "missing either") -}) - -# === Tests migrated from test_s4Constructors.R (QtlDataset) === +# =========================================================================== +# QtlDataset construction and validity +# =========================================================================== test_that("QtlDataset: builds and validates with a single-context SE", { se <- .sc_makeSe() @@ -2034,17 +1718,9 @@ test_that("QtlDataset: rejects non-SE elements in phenotype list", { }) -test_that("QtlDataset: rejects negative QC cutoffs", { - se <- .sc_makeSe() - expect_error( - QtlDataset( - studyName = "s1", - genotypes = .sc_makeGenotypeHandle(), - phenotypes = list(brain = se), - genotypeFilterParam = GenotypeFilterParam(mafCutoff = -0.1) - ), - "is not >= 0" - ) +test_that("GenotypeFilterParam: rejects negative QC cutoffs", { + expect_error(GenotypeFilterParam(mafCutoff = -0.1), "is not >= 0") + expect_error(GenotypeFilterParam(imissCutoff = Inf), "imissCutoff") }) @@ -2119,23 +1795,62 @@ test_that("QtlDataset: tolerates chr-prefix-only seqname differences for a share }) # =========================================================================== -# MultiStudyQtlDataset +# updateObject # =========================================================================== -test_that("MultiStudyQtlDataset: rejects non-QtlDataset entries", { - qd <- QtlDataset( - studyName = "s1", - genotypes = .sc_makeGenotypeHandle(), - phenotypes = list(brain = .sc_makeSe()) - ) - expect_error( - MultiStudyQtlDataset(qtlDatasets = list(s1 = qd, s2 = "not a dataset")), - "must be a QtlDataset" +test_that("updateObject drops the slots a QtlDataset no longer has", { + data(qtlDatasetExample) + old <- qtlDatasetExample + attr(old, "mafCutoff") <- 0.01 + attr(old, "keepIndel") <- TRUE + up <- updateObject(old) + expect_null(attr(up, "mafCutoff")) + expect_null(attr(up, "keepIndel")) + expect_true(methods::validObject(up)) + expect_message( + updateObject(qtlDatasetExample, verbose = TRUE), + "updateObject\\(object = 'QtlDataset'\\)" + ) +}) + +test_that("updateObject renames study and reads saved genotypes again", { + data(qtlDatasetExample) + current <- .qtlGenotypeSe(qtlDatasetExample) + # Saved by a version that named the slot `study` and read PLINK1 files + # through a GenotypeHandle (helper-savedObjects.R). + saved <- .savedHandlePanel(current, .ldRefSource(current)$path, "plink1") + old <- .savedUnder( + .qtlWithGenotypeHandle(qtlDatasetExample, saved), + c(study = "studyName") + ) + up <- updateObject(old) + expect_true(methods::validObject(up)) + expect_identical(studyName(up), studyName(qtlDatasetExample)) + geno <- .qtlGenotypeSe(up) + expect_s4_class(.panelSeed(geno), "GenotypeDosageSeed") + expect_identical(dimnames(geno), dimnames(current)) + expect_identical( + SummarizedExperiment::colData(geno), + SummarizedExperiment::colData(current) ) }) +test_that("updateObject refuses a QtlDataset whose genotypes cannot be read", { + data(qtlDatasetExample) + current <- .qtlGenotypeSe(qtlDatasetExample) + gone <- .savedHandlePanel( + current, + file.path(tempdir(), "nowhere"), + "plink1" + ) + old <- .qtlWithGenotypeHandle(qtlDatasetExample, gone) + cnd <- tryCatch(updateObject(old), error = identity) + expect_s3_class(cnd, "pecotmrUnreadablePanel") +}) -# === Tests migrated from test_showMethods.R (QtlDataset) === +# =========================================================================== +# show() +# =========================================================================== test_that("show.QtlDataset lists context names and trait count", { qd <- .sh_makeQtlDataset() @@ -2146,35 +1861,6 @@ test_that("show.QtlDataset lists context names and trait count", { expect_true(any(grepl("Genotypes: plink2 @ /tmp/test", out))) }) - -test_that("show.MultiStudyQtlDataset reports per-source study counts", { - qd1 <- .sh_makeQtlDataset(studyName = "s1") - qd2 <- .sh_makeQtlDataset(studyName = "s2") - mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) - out <- capture.output(show(mt)) - expect_true(any(grepl( - "MultiStudyQtlDataset: 2 individual-level \\+ 0 sumstats", - out - ))) - expect_true(any(grepl("Individual-level studies: s1, s2", out))) -}) - - -test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { - qd <- .sh_makeQtlDataset(studyName = "s1") - ss <- QtlSumStats( - studyName = "s2", - context = "c1", - trait = "t1", - entry = list(.sh_makeQtlSumstatsGr()), - genome = "hg19", - ldReference = .sh_makeGenotypeHandle() - ) - mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd), sumStats = ss) - out <- capture.output(show(mt)) - expect_true(any(grepl("Sumstats studies: s2", out))) -}) - # =========================================================================== # Multi-region variant extraction: genotypes() with a multi-range region # (the mechanism behind jointRegions). Single-file (chr21) and sharded @@ -2201,8 +1887,12 @@ test_that("show.MultiStudyQtlDataset reports sumstats studies when present", { colData = S4Vectors::DataFrame(row.names = samples) ) } -.mr_ncol <- function(qd, region) ncol(genotypes(qd, region = region)) -.mr_vids <- function(qd, region) colnames(genotypes(qd, region = region)) +# A pipeline's extraction over an analysis window of one or more ranges. +.mr_geno <- function(qd, window) { + pecotmr:::.qtlExtractBlock(qd, window = window)$geno +} +.mr_ncol <- function(qd, window) ncol(.mr_geno(qd, window)) +.mr_vids <- function(qd, window) colnames(.mr_geno(qd, window)) test_that("multi-range region unions disjoint sub-ranges on one chromosome", { skip_if_not_installed("pgenlibr") @@ -2264,8 +1954,8 @@ test_that("multi-range region spans chromosomes on a sharded handle", { expect_gt(n22, 0L) expect_equal(.mr_ncol(qd, rBoth), n21 + n22) - gBoth <- genotypes(qd, region = rBoth) - g21 <- genotypes(qd, region = r21) + gBoth <- .mr_geno(qd, rBoth) + g21 <- .mr_geno(qd, r21) expect_equal(unname(gBoth[, seq_len(n21)]), unname(g21)) expect_true(all(grepl("_c22$", colnames(gBoth)[(n21 + 1):(n21 + n22)]))) }) @@ -2285,79 +1975,57 @@ test_that("multi-region: single-range extraction is unchanged (regression)", { expect_equal(.mr_ncol(qd, r), nrow(snpInfo(h))) }) -test_that(".qtlResolveVariantRegion rejects a non-GRanges / empty region", { - skip_if_not_installed("pgenlibr") - h <- GenotypeHandle( - plink2Prefix = file.path(test_data_dir, "test_variants") - ) - qd <- QtlDataset( - studyName = "S", - genotypes = h, - phenotypes = list(ctx = .mr_makeSE(sampleIds(h))) - ) - expect_error( - genotypes(qd, region = "chr21:1-2"), - "Must inherit from class 'GRanges'" - ) - expect_error( - genotypes(qd, region = GenomicRanges::GRanges()), - "at least one range" - ) -}) - # =========================================================================== -# Accessors: genotypeCovariates / scaleResiduals / phenotypeCovariates +# Accessors: genotypeCovariates / phenotypeCovariates # =========================================================================== -test_that("genotypeCovariates / scaleResiduals return their slots", { +test_that("genotypeCovariates returns the genotype experiment's colData", { gc <- matrix( rnorm(12 * 2), nrow = 12, ncol = 2, dimnames = list(paste0("s", 1:12), c("pc1", "pc2")) ) - qd <- .qr_makeDataset( - contexts = "brain", - geno_cov = gc, - scaleResiduals = FALSE - ) + qd <- .qr_makeDataset(contexts = "brain", geno_cov = gc) + # The covariates live on the genotype experiment's colData, one row per + # panel sample. + cd <- SummarizedExperiment::colData(pecotmr:::.qtlGenotypeSe(qd)) + expect_equal(colnames(cd), c("pc1", "pc2")) + expect_equal(rownames(cd), sampleIds(genotypeHandle(qd))) expect_identical( genotypeCovariates(qd), pecotmr:::.qtlColDataMatrix(pecotmr:::.qtlGenotypeSe(qd)) ) expect_equal(unname(genotypeCovariates(qd)), unname(gc)) - expect_false(scaleResiduals(qd)) - qd2 <- .qr_makeDataset(contexts = "brain", scaleResiduals = TRUE) - expect_true(scaleResiduals(qd2)) }) test_that("phenotypeCovariates returns per-context colData matrices", { qd <- .qr_makeDataset(contexts = c("brain", "liver")) - out <- phenotypeCovariates(qd, contexts = c("brain", "liver")) + out <- phenotypeCovariates(qd, context = c("brain", "liver")) expect_equal(names(out), c("brain", "liver")) expect_true(is.matrix(out$brain)) expect_setequal(colnames(out$brain), c("sex", "age")) expect_equal(nrow(out$brain), 12L) # Single-context request still returns a named list of length 1. - one <- phenotypeCovariates(qd, contexts = "liver") + one <- phenotypeCovariates(qd, context = "liver") expect_equal(names(one), "liver") }) test_that("phenotypeCovariates: requires contexts and rejects unknown ones", { qd <- .qr_makeDataset(contexts = "brain") - expect_error(phenotypeCovariates(qd), "`contexts` is required") + expect_error(phenotypeCovariates(qd), "`context` is required") expect_error( - phenotypeCovariates(qd, contexts = character(0)), - "`contexts` is required" + phenotypeCovariates(qd, context = character(0)), + "`context` is required" ) expect_error( - phenotypeCovariates(qd, contexts = "ghost"), + phenotypeCovariates(qd, context = "ghost"), "Unknown context" ) }) # =========================================================================== -# .qtlResolveVariantRegion: region-path cisWindow validation (line ~247) +# .qtlResolveVariantRegion: region-path cisWindow validation # =========================================================================== test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative cisWindow", { @@ -2383,12 +2051,15 @@ test_that(".qtlResolveVariantRegion: region path rejects a non-scalar/negative c test_that(".qtlExtractBlock: keepIndel = FALSE with an all-indel panel returns an empty block", { # Every variant a multi-base allele, so the indel filter drops them all. - qd <- .qh_makeDataset(a1 = rep("AT", 6L), keepIndel = FALSE) + qd <- .qh_makeDataset(a1 = rep("AT", 6L)) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(keepIndel = FALSE) + ) expect_equal(ncol(blk$geno), 0L) expect_equal(nrow(blk$geno), 0L) expect_equal(blk$variantIds, character(0)) @@ -2398,10 +2069,7 @@ test_that(".qtlExtractBlock: keepIndel = FALSE with an all-indel panel returns a test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero-sample block", { qd <- .qh_makeDataset() # none are panel samples - qd <- pecotmr:::.qtlApplyFilterOverrides( - qd, - GenotypeFilterParam(keepSamples = c("zzz1", "zzz2")) - ) + qd <- pecotmr:::.qtlRestrictSamples(qd, c("zzz1", "zzz2")) local_mocked_bindings( extractBlockGenotypes = .qh_mockExtractor(), .package = "pecotmr" @@ -2459,12 +2127,15 @@ test_that(".qtlExtractBlock: keepSamples disjoint from the panel returns a zero- test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean-imputes the rest", { # s1 (100% NA) dropped; s2 (1 NA) kept then imputed - qd <- .qh_makeDataset(imissCutoff = 0.5) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_naExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(imissCutoff = 0.5) + ) expect_false("s1" %in% blk$sampleIds) expect_true("s2" %in% blk$sampleIds) expect_false(anyNA(blk$geno)) # scattered NA was mean-imputed @@ -2512,12 +2183,15 @@ test_that(".qtlExtractBlock: imissCutoff drops high-missingness samples and mean } test_that(".qtlExtractBlock: xvarCutoff drops near-constant (low-variance) variants", { - qd <- .qh_makeDataset(xvarCutoff = 0.01) + qd <- .qh_makeDataset() local_mocked_bindings( extractBlockGenotypes = .qh_lowVarExtractor(), .package = "pecotmr" ) - blk <- pecotmr:::.qtlExtractBlock(qd) + blk <- pecotmr:::.qtlExtractBlock( + qd, + filter = .qh_filter(xvarCutoff = 0.01) + ) expect_false("rs1" %in% blk$variantIds) # constant column dropped on variance expect_true(ncol(blk$geno) >= 1L) }) @@ -2528,36 +2202,40 @@ test_that(".qtlExtractBlock: xvarCutoff drops near-constant (low-variance) varia test_that("molecularTraits: requires contexts", { qd <- .qr_makeDataset() - expect_error(molecularTraits(qd), "`contexts` is required") + expect_error(molecularTraits(qd), "`context` is required") expect_error( - molecularTraits(qd, contexts = character(0)), - "`contexts` is required" + molecularTraits(qd, context = character(0)), + "`context` is required" ) }) test_that("molecularTraits: unknown context errors", { qd <- .qr_makeDataset() - expect_error(molecularTraits(qd, contexts = "ghost"), "Unknown context") + expect_error(molecularTraits(qd, context = "ghost"), "Unknown context") }) -test_that("molecularTraits: region keeps only overlapping traits", { +test_that("a pipeline's window keeps only the overlapping traits", { qd <- .qr_makeDataset(contexts = "brain") # brain SE: ENSG1 @ chr1:1000-1499, ENSG2 @ chr1:2000-2499. region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900, 1600)) - out <- molecularTraits(qd, contexts = "brain", region = region) + out <- pecotmr:::.qtlMolecularTraits( + qd, + contexts = "brain", + window = region + )[["brain"]] expect_s4_class(out, "SummarizedExperiment") expect_equal(rownames(out), "ENSG1") }) -test_that("molecularTraits: non-overlapping region + naAction='drop' hits the empty-Y short-circuit", { +test_that("an unmatched window under naAction = 'drop' gives an empty SE", { qd <- .qr_makeDataset(contexts = "brain") region <- GenomicRanges::GRanges("chr2", IRanges::IRanges(1, 100)) # no overlap - out <- molecularTraits( + out <- pecotmr:::.qtlMolecularTraits( qd, contexts = "brain", - region = region, - naAction = "drop" - ) + window = region, + phenotypeFilter = .qr_pheno(naAction = "drop") + )[["brain"]] expect_s4_class(out, "SummarizedExperiment") expect_equal(nrow(out), 0L) }) @@ -2585,26 +2263,12 @@ test_that(".qtlOutlierKeepMask: robustbase covMcd failure falls back to colMeans ) set.seed(8L) Y <- matrix(c(rnorm(29), 60), ncol = 1L) - keep <- pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 1e-3) - expect_length(keep, 30L) - expect_false(keep[[30L]]) # the planted 60 is still flagged -}) - -test_that(".qtlOutlierKeepMask: falls back with a message when robustbase is absent", { - # Force the robustbase-absent branch by mocking base::requireNamespace. - local_mocked_bindings( - requireNamespace = function(package, ...) { - if (identical(package, "robustbase")) FALSE else TRUE - }, - .package = "base" - ) - set.seed(5L) - Y <- matrix(c(rnorm(29), 50), ncol = 1L) expect_message( keep <- pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 1e-3), - "install 'robustbase'" + "robustbase's MCD estimator failed" ) expect_length(keep, 30L) + expect_false(keep[[30L]]) # the planted 60 is still flagged }) # =========================================================================== @@ -2720,7 +2384,7 @@ test_that(".qtlBuildResidualizationDesign: disjoint blocks error", { }) # =========================================================================== -# getResidualized{Genotypes,Phenotypes}: disjoint sample-set errors +# residualized{Genotypes,Phenotypes}: disjoint sample-set errors # =========================================================================== test_that("residualizedGenotypes: errors when genotypes and covariates share no samples", { @@ -2738,7 +2402,7 @@ test_that("residualizedGenotypes: errors when genotypes and covariates share no expect_error( residualizedGenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( residualizePhenotype = FALSE, genotypeCovariates = c("pc1", "pc2") @@ -2759,7 +2423,7 @@ test_that("residualizedPhenotypes: errors when phenotypes and covariates share n expect_error( residualizedPhenotypes( qd, - contexts = "brain", + context = "brain", residualizationParam = ResidualizationParam( residualizePhenotype = FALSE, genotypeCovariates = c("pc1", "pc2") @@ -2769,37 +2433,6 @@ test_that("residualizedPhenotypes: errors when phenotypes and covariates share n ) }) -test_that("QtlDataset filter accessors report the construction settings", { - data(qtlDatasetExample, envir = environment()) - x <- qtlDatasetExample - expect_type(mafCutoff(x), "double") - expect_length(mafCutoff(x), 1L) - expect_length(macCutoff(x), 1L) - expect_length(xvarCutoff(x), 1L) - expect_length(imissCutoff(x), 1L) - expect_type(keepIndel(x), "logical") - expect_type(keepVariants(x), "character") -}) - -test_that("QtlDataset filter accessors round-trip what was passed in", { - data(qtlDatasetExample, envir = environment()) - x <- .qtlApplyFilterOverrides( - qtlDatasetExample, - GenotypeFilterParam( - mafCutoff = 0.05, - macCutoff = 10, - xvarCutoff = 0.01, - imissCutoff = 0.1, - keepIndel = FALSE - ) - ) - expect_equal(mafCutoff(x), 0.05) - expect_equal(macCutoff(x), 10) - expect_equal(xvarCutoff(x), 0.01) - expect_equal(imissCutoff(x), 0.1) - expect_false(keepIndel(x)) -}) - 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 @@ -2899,19 +2532,6 @@ test_that("the dosage assay is delayed and oriented variants x samples", { expect_equal(ncol(a), length(sampleIds(handle))) }) -test_that("genotype covariates live on the genotype experiment's colData", { - qd <- .qm_makeDataset() - cd <- SummarizedExperiment::colData(pecotmr:::.qtlGenotypeSe(qd)) - expect_equal(colnames(cd), c("pc1", "pc2")) - expect_equal(rownames(cd), sampleIds(genotypeHandle(qd))) - expect_equal( - genotypeCovariates(qd), - pecotmr:::.qtlColDataMatrix( - pecotmr:::.qtlGenotypeSe(qd) - ) - ) -}) - test_that("subsetting by sample keeps the class and its own slots", { qd <- .qm_makeDataset() out <- qd[, paste0("s", 1:5), ] @@ -2919,7 +2539,6 @@ test_that("subsetting by sample keeps the class and its own slots", { expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) expect_equal(studyName(out), studyName(qd)) expect_identical(genotypeHandle(out), genotypeHandle(qd)) - expect_equal(mafCutoff(out), mafCutoff(qd)) }) test_that("subsetting by context keeps the genotype experiment", { @@ -2938,36 +2557,28 @@ test_that("subsetting by context keeps the genotype experiment", { expect_true(validObject(out)) }) -test_that("subsetting by sample and context together narrows both axes", { - # `x[, j, k]`: the experiment axis is applied here, then the remaining +test_that("subsetting by context also applies feature and sample subscripts", { + # `x[i, j, k]`: the experiment axis is applied here, then the remaining # axes go back through the method with no `k` so the inherited one runs. + # With no sample subscript, every sample survives. qd <- .qm_makeDataset() - out <- suppressWarnings(suppressMessages(qd[, paste0("s", 1:5), "brain"])) - expect_s4_class(out, "QtlDataset") - expect_equal(contexts(out), "brain") - expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) - expect_true(validObject(out)) -}) - -test_that("subsetting by feature and context leaves the samples alone", { - # `x[i, , k]`: no sample subscript, so every sample survives. - qd <- .qm_makeDataset() - out <- suppressWarnings(suppressMessages(qd[1, , "brain"])) - expect_s4_class(out, "QtlDataset") - expect_equal(contexts(out), "brain") - expect_equal(nrow(MultiAssayExperiment::colData(out)), 12L) - expect_true(validObject(out)) -}) - -test_that("all three subscripts can be given at once", { - qd <- .qm_makeDataset() - out <- suppressWarnings(suppressMessages( - qd[1, paste0("s", 1:5), "brain"] - )) - expect_s4_class(out, "QtlDataset") - expect_equal(contexts(out), "brain") - expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) - expect_true(validObject(out)) + s5 <- str_c("s", 1:5) + cases <- suppressWarnings(suppressMessages(list( + `sample and context` = list(out = qd[, s5, "brain"], nSamples = 5L), + `feature and context` = list(out = qd[1, , "brain"], nSamples = 12L), + `all three` = list(out = qd[1, s5, "brain"], nSamples = 5L) + ))) + for (case in names(cases)) { + out <- cases[[case]]$out + expect_true(is(out, "QtlDataset"), info = case) + expect_equal(contexts(out), "brain", info = case) + expect_equal( + nrow(MultiAssayExperiment::colData(out)), + cases[[case]]$nSamples, + info = case + ) + expect_true(validObject(out), info = case) + } }) test_that("the experiment subscript accepts logical and numeric, not just names", { @@ -3152,13 +2763,6 @@ test_that("QtlDataset still rejects a genotype source it cannot open", { # guards were never executed. # =========================================================================== -test_that("validity rejects a non-scalar scaleResiduals", { - # The constructor coerces via isTRUE(); validity guards direct slot sets. - qd <- .qh_makeDataset() - qd@scaleResiduals <- c(TRUE, FALSE) - expect_error(validObject(qd), "Variable 'scaleResiduals'") -}) - test_that("the phenotype-list check rejects duplicated context names", { se <- .qh_makeSe() errs <- pecotmr:::.qtlCheckPhenotypeList(list(brain = se, brain = se)) @@ -3253,16 +2857,34 @@ test_that("aligning covariates with nothing to align returns NULL", { expect_null(pecotmr:::.qtlAlignCovariates(list(), NULL)) }) -test_that("outlier detection reports a singular trait covariance", { - # A singular covariance silently became a pseudo-inverse, while the - # sibling robustbase-missing branch already informed the user. +test_that("outlier detection reports a singular trait covariance once", { + skip_if_not_installed("robustbase") + # robustbase::covMcd() warns, in its own words, that the samples lie + # on a line; that warning is the one signal, so pecotmr adds none. Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 4, 6, 8)) - cnd <- rlang::catch_cnd( - pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 0.05), - classes = "message" + expect_warning( + expect_no_message( + keep <- pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 0.05) + ), + "covariance matrix of the data is singular" ) - expect_match(conditionMessage(cnd), "singular") - expect_match(conditionMessage(cnd), "pseudo-inverse") + expect_length(keep, 4L) +}) + +test_that("a non-robust fallback announces its own singular covariance", { + skip_if_not_installed("robustbase") + # With no MCD there is no robustbase warning, so pecotmr says both what + # it fell back to and that it took a pseudo-inverse. + local_mocked_bindings( + covMcd = function(...) stop("forced covMcd failure"), + .package = "robustbase" + ) + Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 4, 6, 8)) + msgs <- capture_messages( + pecotmr:::.qtlOutlierKeepMask(Y, pvalThreshold = 0.05) + ) + expect_true(any(str_detect(msgs, "MCD estimator failed"))) + expect_true(any(str_detect(msgs, "pseudo-inverse"))) }) test_that(".qtlConcat answers an empty list for no pieces", { @@ -3309,17 +2931,16 @@ test_that("the three filter bundles are separate on purpose", { }) test_that("an unset genotype filter field is absent, not NULL", { - # Absence is what distinguishes "pin this value" from "leave it alone": - # QtlDataset resolves an unset field to its own default, a pipeline - # leaves the dataset's construct-time slot untouched. + # The bundle reports only what was set; a run resolves an unset field to + # its default (.qtlResolveFilter()). expect_length(GenotypeFilterParam(), 0L) expect_equal(names(GenotypeFilterParam(mafCutoff = 0)), "mafCutoff") - # A pinned zero is NOT the same as unset. + # A set zero is reported; an unset field is not. expect_equal(GenotypeFilterParam(mafCutoff = 0)$mafCutoff, 0) expect_null(GenotypeFilterParam()$mafCutoff) }) -test_that("every GenotypeFilterParam field is one QtlDataset resolves", { +test_that("every GenotypeFilterParam field is one a run resolves", { expect_setequal( names(formals(GenotypeFilterParam)), names(pecotmr:::.qtlResolveFilter(GenotypeFilterParam())) @@ -3396,9 +3017,94 @@ test_that("a QtlDataset reads genotypes held in memory as from a file", { expect_null(genotypeHandle(qd)) region <- SummarizedExperiment::rowRanges(disk)[1:30] expect_equal( - genotypes(qd, region = region), - genotypes(qtlDatasetExample, region = region) + genotypes(qd[region, , ]), + genotypes(qtlDatasetExample[region, , ]) ) out <- capture.output(show(qd)) expect_true(any(grepl("held in memory", out))) }) + +# =========================================================================== +# PhenotypeFilterParam: the run's phenotype QC +# =========================================================================== + +test_that("PhenotypeFilterParam: unset fields take each pipeline's default", { + p <- PhenotypeFilterParam() + expect_length(p, 0L) + fm <- pecotmr:::.fmResolvePhenotypeFilter(p) + expect_equal(fm$naAction, "drop") + expect_equal(fm$outlierAction, "keep") + expect_equal(fm$outlierPvalThreshold, 1e-3) + expect_s4_class(fm$outlierArgs, "MethodOptions") + # colocboost takes missing phenotypes as they are. + expect_equal(pecotmr:::.cbResolvePhenotypeFilter(p)$naAction, "keep") + tw <- pecotmr:::.twasResolvePhenotypeFilter( + PhenotypeFilterParam(naAction = "impute", outlierPvalThreshold = 0.01) + ) + expect_equal(tw$naAction, "impute") + expect_equal(tw$outlierPvalThreshold, 0.01) +}) + +test_that("PhenotypeFilterParam: a fit that cannot take NAs refuses 'keep'", { + keep <- PhenotypeFilterParam(naAction = "keep") + expect_error( + pecotmr:::.fmResolvePhenotypeFilter(keep), + "fineMappingPipeline: naAction = \"keep\" is not available" + ) + expect_error( + pecotmr:::.twasResolvePhenotypeFilter(keep), + "twasWeightsPipeline: .*Use \"drop\" or \"impute\"" + ) + expect_equal(pecotmr:::.cbResolvePhenotypeFilter(keep)$naAction, "keep") +}) + +test_that("PhenotypeFilterParam: a bad value is named where it is set", { + expect_error(PhenotypeFilterParam(naAction = "zap"), "naAction") + expect_error(PhenotypeFilterParam(outlierAction = "zap"), "outlierAction") + expect_error( + PhenotypeFilterParam(outlierPvalThreshold = 2), + "outlierPvalThreshold" + ) + expect_error(PhenotypeFilterParam(outlierArgs = list()), "outlierArgs") + # A record built for another engine means nothing to the detector. + expect_error( + PhenotypeFilterParam(outlierArgs = GlmnetOptions()), + "must be built with CovMcdOptions\\(\\) \\(got a record for glmnet" + ) + expect_s4_class( + PhenotypeFilterParam(outlierArgs = CovMcdOptions(alpha = 0.9)), + "PhenotypeFilterParam" + ) + expect_error( + pecotmr:::.fmResolvePhenotypeFilter(GenotypeFilterParam()), + "PhenotypeFilterParam" + ) +}) + +test_that("molecularTraits / residualizedPhenotypes: lists for one context", { + qd <- .qr_makeDataset(contexts = "brain") + mt <- molecularTraits(qd, context = "brain") + expect_type(mt, "list") + expect_named(mt, "brain") + expect_s4_class(mt[["brain"]], "SummarizedExperiment") + rp <- residualizedPhenotypes(qd, context = "brain") + expect_named(rp, "brain") + expect_true(is.matrix(rp[["brain"]])) +}) + +# =========================================================================== +# .qtlResidualizeQr +# =========================================================================== + +test_that("a constant genotype column comes back as zeros, not NaN", { + # `.qtlResidualizeQr()` treats anything below sqrt(.Machine$double.eps) as + # constant: lm.fit residuals of a constant column are ~1e-16 rather than + # 0, and dividing the (also tiny) residuals by that amplifies roundoff to + # unit scale. The column is zeroed instead, and .dropZeroVariance() + # removes it downstream. + Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 2, 2, 2)) + out <- pecotmr:::.qtlResidualizeQr(Y, NULL, scaleResiduals = TRUE) + expect_equal(unname(out[, "b"]), rep(0, 4)) + expect_equal(sd(out[, "a"]), 1) + expect_false(anyNA(out)) +}) diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index ba5b4625..ab355d3e 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(ldReference(res)) + expect_identical(ldReference(res), list()) }) @@ -57,9 +57,11 @@ test_that("QtlFineMappingResult: stores an LD sketch when supplied", { entry = list(e), ldReference = gh ) - # The slot holds the panel; the handle it reads through is its seed. - expect_s4_class(ldReference(res), "RangedSummarizedExperiment") - expect_identical(pecotmr:::.ldRefHandle(ldReference(res)), gh) + # The reference is a panel; the handle it reads through is its seed. + refs <- ldReference(res) + expect_named(refs, res$ldReference) + expect_s4_class(refs[[1L]], "RangedSummarizedExperiment") + expect_identical(pecotmr:::.ldRefHandle(refs[[1L]]), gh) }) @@ -160,19 +162,6 @@ test_that("QtlFineMappingResult: single-row collection allows omitting selectors }) -test_that("QtlFineMappingResult: show prints summary", { - e <- .sc_makeFineMappingRow(3) - res <- QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(e) - ) - expect_output(show(res), "QtlFineMappingResult") -}) - - test_that("QtlFineMappingResult: joint columns absent by default", { e <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( @@ -270,10 +259,6 @@ test_that("QtlFineMappingResult: length-mismatched joint vector errors", { ) }) -# =========================================================================== -# GwasFineMappingResult -# =========================================================================== - # === Tests migrated from test_showMethods.R (QtlFineMappingResult) === test_that("show.QtlFineMappingResult prints entry/study/context/trait/method counts", { @@ -329,7 +314,7 @@ test_that("QtlFineMappingResult: pip returns named pip vector for selected tuple }) -test_that("QtlFineMappingResult: pip(returnList = TRUE) wraps in pipe-keyed list", { +test_that("QtlFineMappingResult: pip() is one named numeric vector", { e <- .ca_makeFmEntry(3) res <- QtlFineMappingResult( studyName = "s1", @@ -338,125 +323,13 @@ test_that("QtlFineMappingResult: pip(returnList = TRUE) wraps in pipe-keyed list method = "susie", entry = list(e) ) - out <- pip(res, returnList = TRUE) - expect_true(is.list(out)) - expect_equal(names(out), "s1|c1|t1|susie") + out <- pip(res) + expect_type(out, "double") + expect_length(out, 3L) + expect_error(pip(res, returnList = TRUE), "unused") }) -test_that("QtlFineMappingResult: credibleSets filters to credible sets", { - e <- .ca_makeFmEntry(3) # cs_95 = c("susie_1", "susie_1", "susie_0") - res <- QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(e) - ) - cs <- credibleSets(res) - expect_equal(nrow(cs), 2L) -}) - - -test_that("QtlFineMappingResult: topLoci returns the entry's topLoci (projected)", { - e <- .ca_makeFmEntry(3) - res <- QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(e) - ) - tl <- topLoci(res, signalCutoff = 0) - expect_equal(length(tl), 3L) - expect_equal(tl$variant_id, .ca_makeTopLoci(3)$variant_id) -}) - -test_that("QtlFineMappingResult: topLoci aggregates entries when selectors do not pin one", { - # Two entries, no selectors: the old behaviour errored ("2 entries; pass - # study/context/trait/method"). Now it stacks the per-variant tables, - # prefixed with the row identity so variants stay attributable. - e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) - res <- QtlFineMappingResult( - studyName = c("s1", "s1"), - context = c("c1", "c2"), - trait = c("t1", "t1"), - method = c("susie", "susie"), - entry = list(e1, e2) - ) - agg <- topLoci(res, signalCutoff = 0) - expect_equal(length(agg), 5L) - expect_true(all( - c("study", "context", "trait", "blockId", "method") %in% - names(S4Vectors::mcols(agg)) - )) - expect_equal(agg$context, c("c1", "c1", "c1", "c2", "c2")) - expect_true("variant_id" %in% names(S4Vectors::mcols(agg))) - # QTL results key on context/trait, so blockId is NA-filled. - expect_true(all(is.na(agg$blockId))) - # the added per-variant `method` must not duplicate the identity column - expect_equal(sum(names(S4Vectors::mcols(agg)) == "method"), 1L) -}) - -test_that("QtlFineMappingResult: topLoci with a full tuple keeps the bare (id-free) table", { - e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) - res <- QtlFineMappingResult( - studyName = c("s1", "s1"), - context = c("c1", "c2"), - trait = c("t1", "t1"), - method = c("susie", "susie"), - entry = list(e1, e2) - ) - tl <- topLoci( - res, - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - signalCutoff = 0 - ) - expect_equal(length(tl), 3L) - # single-entry fast path, unchanged - expect_false(is_in("context", names(S4Vectors::mcols(tl)))) -}) - -test_that("QtlFineMappingResult: topLoci aggregates only the matching subset", { - e1 <- .sc_makeFineMappingRow(3) - e2 <- .sc_makeFineMappingRow(2) - res <- QtlFineMappingResult( - studyName = c("s1", "s1"), - context = c("c1", "c2"), - trait = c("t1", "t1"), - method = c("susie", "susie"), - entry = list(e1, e2) - ) - sub <- topLoci(res, context = "c2", signalCutoff = 0) - expect_equal(length(sub), 2L) - expect_equal(unique(sub$context), "c2") -}) - -test_that("QtlFineMappingResult: topLoci on a single-row collection still carries identity columns", { - # A no-selector call takes the aggregate path even for one row, so the PIP - # table has a uniform shape (identity columns present) whatever the row count - # -- callers don't special-case single-entry results. - res <- QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(.sc_makeFineMappingRow(4)) - ) - tl <- topLoci(res, signalCutoff = 0) - expect_equal(length(tl), 4L) - expect_true(all( - c("study", "context", "trait", "method", "variant_id") %in% - names(S4Vectors::mcols(tl)) - )) - expect_equal(unique(tl$context), "c1") -}) - test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible sets with identity columns", { # e1 (n=3) has cs_95 = susie_1/susie_1/susie_0 -> 2 CS members; e2 (n=2) -> 2. e1 <- .sc_makeFineMappingRow(3) @@ -469,10 +342,10 @@ test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible entry = list(e1, e2) ) cs <- credibleSets(res) - expect_equal(nrow(cs), 4L) + expect_equal(length(cs), 4L) expect_true(all( c("study", "context", "trait", "blockId", "method", "variant_id") %in% - names(cs) + names(S4Vectors::mcols(cs)) )) expect_equal(cs$context, c("c1", "c1", "c2", "c2")) # full tuple still returns the bare per-entry credible-set table @@ -483,8 +356,8 @@ test_that("QtlFineMappingResult: credibleSets aggregates every entry's credible trait = "t1", method = "susie" ) - expect_false("context" %in% names(bare)) - expect_equal(nrow(bare), 2L) + expect_false("context" %in% names(S4Vectors::mcols(bare))) + expect_equal(length(bare), 2L) }) test_that("QtlFineMappingResult: marginalEffects aggregates every entry with identity columns", { @@ -498,8 +371,11 @@ test_that("QtlFineMappingResult: marginalEffects aggregates every entry with ide entry = list(e1, e2) ) me <- marginalEffects(res) - expect_equal(nrow(me), 5L) # all topLoci rows (no CS filter) - expect_true(all(c("study", "context", "trait", "method") %in% names(me))) + expect_equal(length(me), 5L) # all topLoci rows (no CS filter) + expect_true(all( + c("study", "context", "trait", "method") %in% + names(S4Vectors::mcols(me)) + )) expect_equal(unique(me$context), c("c1", "c2")) }) @@ -557,7 +433,7 @@ test_that("cvResult works at the QtlFineMappingResult collection level", { prediction = list(susie_predicted = matrix(0, 1, 1)), performance = list(susie_performance = matrix(0, 1, 6)) ) - e <- fineMappingRow("chr1:100:A:G", list(), tl, cvResult = cv) + e <- FineMappingRow("chr1:100:A:G", list(), tl, cvResult = cv) fmr <- QtlFineMappingResult( studyName = "S", context = "C", @@ -597,15 +473,13 @@ test_that("QtlFineMappingResult: marginalEffects with tuple selectors", { trait = "t1", method = "susie" ) - expect_s3_class(me, "data.frame") - expect_equal(nrow(me), 4L) - expect_true(all(c("variant_id", "beta", "se", "z", "p") %in% names(me))) + expect_s4_class(me, "GRanges") + expect_equal(length(me), 4L) + expect_true(all( + c("variant_id", "beta", "se", "z", "p") %in% names(S4Vectors::mcols(me)) + )) }) -# =========================================================================== -# GwasFineMappingResult collection accessors -# =========================================================================== - # =========================================================================== # Validity: the branches that name what is wrong # @@ -653,20 +527,128 @@ test_that("a joint column must be character, not a factor or number", { ) }) -test_that("a QtlFineMappingResult refuses a region selector", { +test_that("a QtlFineMappingResult refuses a blockId", { data(qtlFineMappingExample) - # Region selection belongs to GwasFineMappingResult. The shared - # FineMappingResultBase accessors pass `region` to every selector, and - # this one used to absorb it in `...` and silently return the - # study/context/trait/method match instead. + x <- qtlFineMappingExample + # Block selection belongs to GwasFineMappingResult. The shared + # FineMappingResultBase accessors pass `blockId` to every selector, and + # this one refuses it rather than return the study/context/trait/method + # match as if it had been honoured. + expect_error(susieFit(x, blockId = "b1"), "has no LD blocks") + expect_error(variantIds(x, blockId = "b1"), "has no LD blocks") + # The supported selectors still work. + expect_type(susieFit(x, method = "susie"), "list") +}) + +test_that("fineMappingResult(QtlFineMappingResult) refuses a blockId", { + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)) + ) + # A QTL fit is one row; `blockId` names a GWAS block, and NA is unset. + expect_equal(nrow(fineMappingResult(res, blockId = NA)), 1L) expect_error( - susieFit(qtlFineMappingExample, region = "chr22:1-2"), - "not region-indexed" + fineMappingResult(res, blockId = "chr1_1_500"), + "`blockId` names an LD block of a GWAS fit" + ) +}) + +test_that("a QTL fit across chromosomes is refused by name", { + ids <- c("chr1:100:A:G", "chr2:100:A:G") + trans <- FineMappingRow( + variantIds = ids, + susieFit = list(), + topLoci = data.frame(variant_id = ids, pip = c(0.6, 0.4)) ) expect_error( - variantIds(qtlFineMappingExample, region = "chr22:1-2"), - "not region-indexed" + QtlFineMappingResult( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("t1", "t2"), + method = c("susie", "susie"), + entry = list(.sc_makeFineMappingRow(3), trans) + ), + "`entry` element\\(s\\) 2 span more than one chromosome" + ) +}) + +test_that("QtlFineMappingResult() keeps the caller's metadata", { + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)), + metadata = list(run = "r1") + ) + expect_equal(S4Vectors::metadata(res), list(run = "r1")) + expect_error( + QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)), + metadata = "r1" + ), + "metadata" + ) +}) + +test_that("each row records the variants its fit was made with", { + row <- .sc_makeFineMappingRow(3) + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(row) + ) + expect_s4_class(res$fitVariants, "CharacterList") + expect_equal( + as.character(res$fitVariants[[1L]]), + pecotmr:::.fmRowFitVariants(row) + ) +}) + +test_that("cvResult() of a narrowed row warns and returns it unchanged", { + tl <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + pip = c(0.5, 0.3, 0.2) + ) + cv <- list(prediction = list(susie = 1:4)) + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(FineMappingRow(tl$variant_id, NULL, tl, cvResult = cv)) + ) + narrowed <- endoapply(res, utils::head, 2L) + expect_warning( + out <- cvResult(narrowed), + "cvResult\\(\\): the stored fit was made with 3 variants" + ) + expect_identical(out, cv) + expect_no_warning(cvResult(res)) +}) + +# =========================================================================== +# Constructor guards +# =========================================================================== + +test_that("QtlFineMappingResult: rejects rows that are not row payloads", { + expect_error( + QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "t1", + method = "susie", + entry = list("not_an_entry") + ), + "must be a fine-mapping row" ) - # The supported selectors still work. - expect_type(susieFit(qtlFineMappingExample, method = "susie"), "list") }) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 7b454701..f8b2b360 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -7,7 +7,11 @@ setClass( "RtlTestKid", contains = "RangedTupleList", - representation(genome = "character", ldReference = "ANY", qcInfo = "list") + representation( + genome = "character", + ldReference = "ANY", + qcOptions = "list" + ) ) .rtl_mk <- function(chr, pos, strand = "*") { @@ -28,7 +32,7 @@ setClass( ), genome = "hg38", ldReference = "SKETCH", - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) S4Vectors::mcols(x) <- S4Vectors::DataFrame( study = c("s1", "s2", "s3"), @@ -57,7 +61,7 @@ test_that("ncol is zero when the collection has no mcols", { GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1:2)), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) expect_equal(ncol(bare), 0L) expect_equal(nrow(bare), 1L) @@ -88,7 +92,7 @@ test_that("$<- works on a collection that had no mcols at all", { GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1:2)), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) bare$study <- "s1" expect_equal(bare$study, "s1") @@ -133,7 +137,7 @@ test_that("validity rejects an element spanning two seqnames", { GenomicRanges::GRangesList(a = .rtl_mk(c("chr1", "chr2"), c(1, 2))), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ), "span more than one" ) @@ -150,7 +154,7 @@ test_that("validity rejects an element spanning two strands", { ), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ), "span more than one" ) @@ -164,7 +168,7 @@ test_that("validity accepts a stranded element as long as it is consistent", { ), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) expect_equal(length(x), 1L) expect_equal(length(range(x)[[1L]]), 1L) @@ -176,7 +180,7 @@ test_that("an empty collection is valid", { GenomicRanges::GRangesList(), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) expect_equal(length(empty), 0L) expect_equal(nrow(empty), 0L) @@ -193,7 +197,7 @@ test_that(".rtlRebuild carries every subclass slot across a rebuild", { x <- .rtl_makeKid() expect_setequal( pecotmr:::.rtlOwnSlots(x), - c("genome", "ldReference", "qcInfo") + c("genome", "ldReference", "qcOptions") ) out <- pecotmr:::.rtlRebuild( x, @@ -203,7 +207,7 @@ test_that(".rtlRebuild carries every subclass slot across a rebuild", { expect_s4_class(out, "RtlTestKid") expect_equal(out@genome, "hg38") expect_equal(out@ldReference, "SKETCH") - expect_equal(out@qcInfo, list(step1 = "ok")) + expect_equal(out@qcOptions, list(step1 = "ok")) expect_equal(out$study, c("s1", "s3")) expect_equal(unname(lengths(out)), c(1L, 1L)) }) @@ -238,52 +242,24 @@ test_that("endoapply rejects a FUN that stops returning GRanges", { }) # =========================================================================== -# subsetRegion +# Narrowing by range with the standard verbs # =========================================================================== -test_that("subsetRegion selects, trims, and drops emptied elements", { - x <- .rtl_makeKid() - out <- subsetRegion( - x, - GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(150, 1050) - ) - ) - # a: 200,300 kept (100 trimmed away); b: 1000 kept; c: chr2, dropped. - expect_equal(length(out), 2L) - expect_equal(names(out), c("a", "b")) - expect_equal(unname(lengths(out)), c(2L, 1L)) - expect_equal(out$study, c("s1", "s2")) - expect_equal(out@genome, "hg38") -}) - -test_that("subsetRegion accepts a chr:start-end string", { - x <- .rtl_makeKid() - out <- subsetRegion(x, "chr2:40-70") - expect_equal(length(out), 1L) - expect_equal(names(out), "c") - expect_equal(out$study, "s3") -}) - -test_that("subsetRegion returns an empty collection when nothing overlaps", { - x <- .rtl_makeKid() - out <- subsetRegion(x, "chr9:1-100") - expect_s4_class(out, "RtlTestKid") - expect_equal(length(out), 0L) - expect_equal(out@genome, "hg38") -}) - -test_that("subsetRegion differs from subsetByOverlaps and restrict", { - # The three operations are genuinely distinct and all three are useful. +test_that("the standard verbs narrow a collection by range", { + # subsetByOverlaps() keeps the elements that overlap, whole; endoapply() + # over it trims each element to the window and keeps the class and its + # collection-level slots. x <- .rtl_makeKid() win <- GenomicRanges::GRanges("chr1", IRanges::IRanges(150, 1050)) byOverlaps <- IRanges::subsetByOverlaps(x, win) - trimmed <- subsetRegion(x, win) - # subsetByOverlaps keeps matching elements WHOLE (a still has 3 variants). + expect_s4_class(byOverlaps, "RtlTestKid") expect_equal(unname(lengths(byOverlaps)), c(3L, 2L)) - # subsetRegion trims them (a keeps 2, b keeps 1). - expect_equal(unname(lengths(trimmed)), c(2L, 1L)) + trimmed <- endoapply(x, IRanges::subsetByOverlaps, ranges = win) + expect_s4_class(trimmed, "RtlTestKid") + # a keeps 200 and 300, b keeps 1000, c (chr2) is left empty. + expect_equal(unname(lengths(trimmed)), c(2L, 1L, 0L)) + expect_equal(trimmed@genome, "hg38") + expect_equal(unname(lengths(trimmed[lengths(trimmed) > 0L])), c(2L, 1L)) }) @@ -313,6 +289,11 @@ test_that(".rtlSplitByBlocks splits one element into per-block pieces", { # `outer.inner` mangling was an artifact, and inconsistent at that). expect_null(names(r$entry)) expect_equal(r$blockId, c("b1", "b2")) + # Each piece carries its block's interval as well as its key. + expect_identical( + as.character(r$blockRange), + c("chr1:1-500", "chr1:800-1200") + ) expect_equal(unname(lengths(r$entry)), c(2L, 1L)) # Both pieces came from the one input element, so its metadata row is # replicated twice. @@ -391,6 +372,7 @@ test_that(".rtlSplitByBlocks handles an empty entry list", { expect_length(r$entry, 0L) expect_length(r$fromIdx, 0L) expect_length(r$blockId, 0L) + expect_length(r$blockRange, 0L) }) test_that(".rtlSplitByBlocks rejects a non-GRanges element", { @@ -420,7 +402,7 @@ test_that("[[<- replaces an element and keeps class, slots and mcols", { # The collection-level slots are exactly what the setAs route would drop. expect_equal(x@genome, "hg38") expect_equal(x@ldReference, "SKETCH") - expect_equal(x@qcInfo, list(step1 = "ok")) + expect_equal(x@qcOptions, list(step1 = "ok")) }) test_that("[[<- leaves the other elements untouched", { @@ -514,6 +496,7 @@ test_that(".rtlGatherElements matches unlist(x[idx]) for every index shape", { x <- .rtl_makeKid() slow <- function(idx) unlist(x[idx], use.names = FALSE) expect_identical(.rtlGatherElements(x, 1L), slow(1L)) + expect_identical(.rtlGatherElements(x, 2L), x[[2]]) expect_identical(.rtlGatherElements(x, c(1L, 3L)), slow(c(1L, 3L))) expect_identical( .rtlGatherElements(x, seq_len(length(x))), @@ -559,13 +542,6 @@ test_that(".rtlGatherElements keeps the elements' inner mcols", { expect_identical(got, unlist(kid[c(1L, 2L)], use.names = FALSE)) }) -test_that(".rtlGatherElements does not re-validate the collection", { - # Nothing here reconstructs the subclass, so a collection whose validity - # would be expensive is not paying for it on every element read. - x <- .rtl_makeKid() - expect_identical(.rtlGatherElements(x, 2L), x[[2]]) -}) - # =========================================================================== # The plyranges bridge: the flatten / nest conversions and the dplyr verbs @@ -700,10 +676,9 @@ test_that("nestTupleRanges validates its arguments", { # --------------------------------------------------------------------------- # plyranges / dplyr verbs. # -# These call the methods directly rather than through the generic: dispatch -# needs the S3method() entries a roxygen regen writes, and the logic under test -# is the same either way. The final test checks dispatch itself, and skips -# until the registration exists. +# These call the methods directly rather than through the generic; the logic +# under test is the same either way. The final test checks dispatch through +# the dplyr generics, which the NAMESPACE's S3method() entries provide. # --------------------------------------------------------------------------- # @noRd @@ -778,18 +753,9 @@ test_that("group_by returns plyranges' own grouped representation", { test_that("the verbs are reachable through the dplyr generics", { - # Needs the S3method() entries from a roxygen regen; skips until then. - # Probed by attempting dispatch rather than by looking the function up: + # Checked by dispatching rather than by looking the function up: # getS3method() finds it in the namespace whether or not it is registered. mc <- .trv_mc() - dispatches <- tryCatch( - { - dplyr::filter(mc, Z > 2) - TRUE - }, - error = function(e) FALSE - ) - skip_if_not(dispatches, "S3 methods not yet registered (regen pending)") expect_s4_class(dplyr::filter(mc, Z > 2), "QtlSumStats") expect_s4_class(dplyr::slice(mc, 1:2), "QtlSumStats") }) @@ -834,6 +800,130 @@ test_that("range keys of an empty collection are empty", { ) }) +test_that("range keys and seqnames are read per element, NA when empty", { + grl <- GenomicRanges::GRangesList( + a = .rtl_mk("chr1", c(100, 300)), + b = GenomicRanges::GRanges(), + c = .rtl_mk("chr2", c(50, 60)) + ) + keys <- pecotmr:::.rtlRangeKeys(grl) + expect_identical(keys, c("chr1_100_300", NA, "chr2_50_60")) + # One formatter keys a single GRanges' span the same way. + expect_identical( + pecotmr:::.rtlOneRangeKey(range(grl[["a"]])), + keys[[1L]] + ) + expect_identical( + pecotmr:::.rtlElementSeqnames(grl), + c("chr1", NA, "chr2") + ) +}) + +test_that("elements bind into the object GRangesList() builds", { + # Plain elements are joined from their vectors; the result must be the + # very object GRangesList() makes, names and seqinfo included. + data( + qtlFineMappingExample, + qtlSumStatsMulticontextExample, + envir = environment() + ) + named <- .rtl_mk("chr1", c(5, 9)) + names(named) <- c("v1", "v2") + stranded <- .rtl_mk("chr3", 7, strand = "+") + GenomeInfoDb::genome(stranded) <- "hg38" + namedColumn <- .rtl_mk("chr1", c(1, 2)) + S4Vectors::mcols(namedColumn)$x <- c(p = 0.1, q = 0.2) + plainColumn <- .rtl_mk("chr2", 3) + S4Vectors::mcols(plainColumn)$x <- 0.3 + cases <- list( + columnNames = list(namedColumn, plainColumn), + fineMapping = as.list(qtlFineMappingExample), + sumStats = as.list(qtlSumStatsMulticontextExample), + withEmpty = list( + .rtl_mk("chr1", 1), + GenomicRanges::GRanges(), + .rtl_mk("chr2", 2) + ), + mixed = list(named, stranded, .rtl_mk("chr1", 3)), + outerNames = list(a = .rtl_mk("chr1", 1), b = .rtl_mk("chr2", 2)) + ) + for (nm in names(cases)) { + # The bare join is the fast path; it reports the seqinfo merge + # warnings .rtlBindElements() silences, as GRangesList() does. + joined <- suppressWarnings( + pecotmr:::.rtlJoinPlainElements(cases[[nm]]) + ) + expect_false(is.null(joined), info = nm) + expect_identical( + pecotmr:::.rtlBindElements(cases[[nm]]), + GenomicRanges::GRangesList(cases[[nm]]), + info = nm + ) + } +}) + +test_that("elements outside the plain case bind through GRangesList()", { + a <- .rtl_mk("chr1", 1) + S4Vectors::mcols(a)$x <- 1L + otherType <- .rtl_mk("chr2", 2) + S4Vectors::mcols(otherType)$x <- 2.5 + otherColumn <- .rtl_mk("chr2", 3) + S4Vectors::mcols(otherColumn)$y <- "z" + matrixColumn <- .rtl_mk("chr2", 4) + S4Vectors::mcols(matrixColumn)$x <- matrix(1:2, nrow = 1L) + withMetadata <- a + S4Vectors::metadata(withMetadata) <- list(source = "test") + cases <- list( + list(a, otherType), + list(a, otherColumn), + list(matrixColumn, matrixColumn), + list(withMetadata, a), + list() + ) + for (els in cases) { + expect_null(pecotmr:::.rtlJoinPlainElements(els)) + expect_identical( + pecotmr:::.rtlBindElements(els), + GenomicRanges::GRangesList(els) + ) + } +}) + +test_that("collections join into the GRangesList of their elements", { + data(qtlSumStatsMulticontextExample, envir = environment()) + x <- qtlSumStatsMulticontextExample + parts <- list(x[1L], x[2:3]) + expect_identical( + pecotmr:::.rtlJoinParts(parts), + GenomicRanges::GRangesList(c(as.list(parts[[1L]]), as.list(x[2:3]))) + ) +}) + +test_that("joining elements on different chromosomes says nothing", { + # Merging their seqinfo warns that the two share no seqlevel, which + # GRangesList() keeps quiet, and so do both joins. + a <- GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1)) + b <- GenomicRanges::GRangesList(b = .rtl_mk("chr2", 2)) + expect_silent(joined <- pecotmr:::.rtlJoinParts(list(a, b))) + expect_identical( + joined, + GenomicRanges::GRangesList(c(as.list(a), as.list(b))) + ) + elements <- list(.rtl_mk("chr1", 1), .rtl_mk("chr2", 2)) + expect_silent(bound <- pecotmr:::.rtlBindElements(elements)) + expect_identical(bound, GenomicRanges::GRangesList(elements)) +}) + +test_that("a variant column is found on all elements or none", { + x <- .rtl_makeKid() + expect_false(pecotmr:::.rtlHasVariantColumn(x, "pip")) + withPip <- GenomicRanges::GRangesList( + a = GenomicRanges::GRanges("chr1:1-2", pip = 0.5), + b = GenomicRanges::GRanges("chr1:5-6", pip = 0.1) + ) + expect_true(pecotmr:::.rtlHasVariantColumn(withPip, "pip")) +}) + test_that("seqinfo is left alone when the source carries none", { # Nothing to restore from, so the rebuild is returned untouched. empty <- new( @@ -841,7 +931,7 @@ test_that("seqinfo is left alone when the source carries none", { GenomicRanges::GRangesList(), genome = "hg38", ldReference = NULL, - qcInfo = list() + qcOptions = list() ) grl <- GenomicRanges::GRangesList( a = GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) @@ -889,7 +979,7 @@ test_that("blockId reads the recorded value, not the variants' span", { variant_id = c("chr1:100:A:G", "chr1:200:C:T"), pip = c(0.9, 0.1) ) - row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) + row <- FineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) res <- GwasFineMappingResult( studyName = "s", method = "susie", @@ -898,3 +988,263 @@ test_that("blockId reads the recorded value, not the variants' span", { ) expect_equal(blockId(res), "chr1_1_1000000") }) + +# =========================================================================== +# updateObject(): collections saved before references became per-row +# =========================================================================== + +# The collections saved this way are built by helper-savedObjects.R. + +test_that("updateObject keys every row of an old collection to its reference", { + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + panel <- ldReference(mc)[[1L]] + old <- .savedWithOneLdRef(mc, panel) + # Read as it was saved, the old object is refused, not taken as LD-free. + expect_error(ldReference(old), "updateObject") + new <- updateObject(old) + expect_true(methods::validObject(new)) + expect_identical(ldReference(new), list(ld1 = panel)) + expect_identical(new$ldReference, rep("ld1", nrow(mc))) + # Saved before the slot was renamed, it holds the reference as ldSketch: + # refused the same way, and brought to the same object. + sketched <- .savedWithLdSketch(mc, panel) + expect_error(ldReference(sketched), "updateObject") + expect_identical(updateObject(sketched), new) +}) + +test_that("updateObject marks every row of an old LD-free collection LD-free", { + data(qtlFineMappingExample) + old <- .savedWithOneLdRef(qtlFineMappingExample, NULL) + # Read as it was saved, it already reads LD-free: a NULL slot meant no + # reference then too, so there is nothing to refuse. + expect_identical(ldReference(old), list()) + new <- updateObject(old) + expect_identical(ldReference(new), list()) + expect_true(all(is.na(new$ldReference))) + # A NULL saved under the old name is read back as NULL, not as the + # placeholder R stores it as. + sketched <- .savedWithLdSketch(qtlFineMappingExample, NULL) + expect_identical(updateObject(sketched), new) +}) + +test_that("updateObject reads a collection's saved PLINK1 reference again", { + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + current <- ldReference(mc)[[1L]] + saved <- .savedHandlePanel( + current, + "pecotmr://extdata/toy_canonical", + "plink1" + ) + up <- updateObject(.savedWithLdSketch(mc, saved)) + ref <- ldReference(up)[[1L]] + expect_s4_class(.panelSeed(ref), "GenotypeDosageSeed") + expect_identical(dimnames(ref), dimnames(current)) + expect_equal( + as.matrix(SummarizedExperiment::assay(ref)[1:3, 1:4]), + as.matrix(SummarizedExperiment::assay(current)[1:3, 1:4]) + ) +}) + +test_that("updateObject keeps a reference it cannot read again, then retries", { + data(qtlFineMappingExample) + files <- str_c( + test_path("test_data", "test_variants"), + c(".bed", ".bim", ".fam") + ) + stem <- file.path(withr::local_tempdir(), "panel") + moved <- str_c(stem, c(".bed", ".bim", ".fam")) + file.copy(files, moved) + saved <- .savedHandlePanel( + readGenotypes(stem, format = "plink1"), + stem, + "plink1" + ) + unlink(moved) + old <- .savedWithLdSketch(qtlFineMappingExample, saved) + # The rest of the collection is brought up to date; the reference is kept + # as saved, and the warning says why. + expect_warning(up <- updateObject(old), "kept as saved") + expect_identical(ldReference(up), list(ld1 = saved)) + # With the files back, updating again finishes the job. + file.copy(files, moved) + again <- updateObject(up) + expect_s4_class(.panelSeed(ldReference(again)[[1L]]), "GenotypeDosageSeed") +}) + +test_that("updateObject leaves a current collection as it is", { + data(qtlSumStatsExample) + expect_identical(updateObject(qtlSumStatsExample), qtlSumStatsExample) + expect_message( + updateObject(qtlSumStatsExample, verbose = TRUE), + "updateObject\\(object = 'QtlSumStats'\\)" + ) +}) + +# =========================================================================== +# Coercion, sort / unique / trim, rebuilt names, and split tuples +# =========================================================================== + +test_that("as(x, 'GRanges') flattens a collection", { + data(qtlFineMappingExample) + expect_identical( + as(qtlFineMappingExample, "GRanges"), + flattenTupleRanges(qtlFineMappingExample) + ) +}) + +test_that("sort, unique and trim return the collection's own class", { + data(qtlSumStatsMulticontextExample) + x <- qtlSumStatsMulticontextExample + # Each element is sorted on its own; the collection keeps its slots and + # its names. + s <- sort(endoapply(x, rev)) + expect_s4_class(s, "QtlSumStats") + expect_identical(GenomicRanges::start(s[[1L]]), sort(start(x[[1L]]))) + expect_identical(ldReference(s), ldReference(x)) + expect_identical(names(s), names(x)) + expect_s4_class(unique(x), "QtlSumStats") + expect_identical(lengths(unique(x)), lengths(x)) + expect_s4_class(trim(x), "QtlSumStats") +}) + +test_that("a rebuild names an unnamed collection from its tuples", { + data(qtlSumStatsMulticontextExample) + x <- qtlSumStatsMulticontextExample + unnamed <- `names<-`(x, NULL) + expect_null(names(unnamed)) + expect_identical(names(endoapply(unnamed, identity)), names(x)) +}) + +test_that("nestTupleRanges returns a split tuple's pieces to their own rows", { + # A fit-less entry on two chromosomes, given one blockId, splits into two + # rows sharing that whole identity; only the chromosome tells their + # ranges apart. + ids <- c("chr1:100:A:G", "chr1:200:A:G", "chr2:100:A:G") + tl <- data.frame(variant_id = ids, pip = c(0.5, 0.3, 0.2)) + x <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(FineMappingRow(ids, susieFit = list(), topLoci = tl)), + blockId = "b1" + ) + expect_identical(x$blockId, c("b1", "b1")) + expect_equal(nrow(x), 2L) + back <- nestTupleRanges(flattenTupleRanges(x), x) + expect_equal(unname(lengths(back)), c(2L, 1L)) + expect_identical( + as.character(unlist(GenomicRanges::seqnames(back), use.names = FALSE)), + c("chr1", "chr1", "chr2") + ) + # An emptied piece has no chromosome, and stays empty. + flat <- flattenTupleRanges(x) + kept <- flat[as.character(GenomicRanges::seqnames(flat)) == "chr1"] + expect_equal(unname(lengths(nestTupleRanges(kept, x))), c(2L, 0L)) +}) + +# =========================================================================== +# Identity columns are character; metadata; genomicRegion() +# =========================================================================== + +test_that("an identity column must be character, and may hold NA", { + # A bare GRangesList takes any table; building the collection from it + # runs validity. + grl <- GenomicRanges::GRangesList(a = .rtl_mk("chr1", 1:2)) + S4Vectors::mcols(grl)$study <- 1L + expect_error( + new( + "RtlTestKid", + grl, + genome = "hg38", + ldReference = NULL, + qcOptions = list() + ), + "the `study` column must be character \\(got integer\\)" + ) + withNa <- .rtl_makeKid() + S4Vectors::mcols(withNa)$gwasContext <- c("c1", NA, "c3") + expect_true(validObject(withNa)) +}) + +test_that("mcols<- and its older spellings refuse a wrong-typed identity", { + x <- .rtl_makeKid() + expect_error( + S4Vectors::mcols(x)$study <- 1:3, + "the `study` column must be character \\(got integer\\)" + ) + expect_error( + S4Vectors::mcols(x) <- S4Vectors::DataFrame(blockId = c(1, 2, 3)), + "the `blockId` column must be character \\(got numeric\\)" + ) + expect_error( + S4Vectors::values(x)$trait <- c(TRUE, FALSE, TRUE), + "the `trait` column must be character \\(got logical\\)" + ) + expect_error( + S4Vectors::elementMetadata(x)$method <- factor(c("a", "b", "c")), + "the `method` column must be character \\(got factor\\)" + ) + # The refused assignments left the collection as it was. + expect_identical(x, .rtl_makeKid()) + # Character identity values, and any other column, are stored. + S4Vectors::mcols(x)$study <- c("a", "b", "c") + S4Vectors::mcols(x)$n <- c(1.5, 2.5, 3.5) + expect_equal(x$study, c("a", "b", "c")) + expect_equal(x$n, c(1.5, 2.5, 3.5)) + expect_s4_class(x, "RtlTestKid") + # Dropping the table leaves no identity column to check. + S4Vectors::mcols(x) <- NULL + expect_equal(ncol(x), 0L) +}) + +test_that("the per-variant metadata level is passed through untouched", { + x <- .rtl_makeKid() + perVariant <- S4Vectors::splitAsList( + S4Vectors::DataFrame(score = seq_len(sum(lengths(x)))), + factor(rep(names(x), lengths(x)), levels = names(x)) + ) + S4Vectors::mcols(x, level = "within") <- perVariant + expect_equal(S4Vectors::mcols(x[[2L]])$score, 4:5) + expect_equal(x$study, c("s1", "s2", "s3")) +}) + +test_that("$<- refuses an identity column of the wrong type", { + x <- .rtl_makeKid() + expect_error( + x$study <- 1:3, + "the `study` column must be character \\(got integer\\)" + ) + expect_error( + x$gwasTrait <- c(1, 2, 3), + "the `gwasTrait` column must be character \\(got numeric\\)" + ) + # Character identity values, and any other column, are taken as given. + x$n <- c(1L, 2L, 3L) + x$study <- c("a", "b", "c") + expect_equal(x$study, c("a", "b", "c")) + expect_equal(x$n, 1:3) +}) + +test_that(".withMetadata attaches a list as the collection's metadata", { + x <- .rtl_makeKid() + out <- pecotmr:::.withMetadata(x, list(source = "unit test")) + expect_equal(S4Vectors::metadata(out), list(source = "unit test")) + expect_identical(pecotmr:::.withMetadata(x, list()), x) + expect_error(pecotmr:::.withMetadata(x, "not a list"), "metadata") +}) + +test_that("genomicRegion() is each row's span unless a region was stored", { + x <- .rtl_makeKid() + expect_equal( + as.character(genomicRegion(x)), + c("chr1:100-300", "chr1:1000-1100", "chr2:50-60") + ) + stored <- GenomicRanges::GRanges( + c("chr1", "chr1", "chr2"), + IRanges::IRanges(c(1L, 901L, 1L), c(500L, 1500L, 100L)) + ) + x$region <- stored + expect_identical(genomicRegion(x), stored) + expect_length(genomicRegion(x[0]), 0L) +}) diff --git a/tests/testthat/test_SldscData.R b/tests/testthat/test_SldscData.R index 7cb3230b..79f9bc25 100644 --- a/tests/testthat/test_SldscData.R +++ b/tests/testthat/test_SldscData.R @@ -68,7 +68,8 @@ test_that("validity rejects a trait without a `single` element", { test_that("annotData / frqData return the stored frames", { sd <- .sldscMkData() - expect_s3_class(annotData(sd), "data.frame") + expect_s4_class(annotData(sd), "DataFrame") + expect_s4_class(frqData(sd), "DataFrame") expect_equal(nrow(annotData(sd)), 6L) expect_equal(nrow(frqData(sd)), 6L) }) @@ -84,25 +85,43 @@ test_that("sldscResults / traitNames expose the traits list", { expect_named(sldscResults(sd), c("traitX", "traitY")) }) -test_that("sldscResults retrieves single (by idx), joint, and NULL cases", { +test_that("sldscResults is one trait-keyed list, whatever is selected", { sd <- .sldscMkData() - single1 <- sldscResults(sd, "traitX", "single", 1L) + one <- sldscResults(sd, "traitX") + expect_named(one, "traitX") + expect_equal( + one[["traitX"]]$joint$categories, + c("annot_A_0", "annot_B_0", "baselineLD_0") + ) + expect_length(one[["traitX"]]$single, 2L) + expect_named(sldscResults(sd, c("traitY", "traitX")), c("traitY", "traitX")) + expect_error( + sldscResults(sd, "no_such_trait"), + "no trait no_such_trait.*It has: traitX, traitY" + ) + expect_error(sldscResults(sd, "traitX", "joint"), "unused argument") +}) + +test_that(".sldscRun retrieves single (by idx), joint, and NULL cases", { + sd <- .sldscMkData() + single1 <- .sldscRun(sd, "traitX", "single", 1L) expect_equal(single1$categories, c("annot_A_0", "baselineLD_0")) expect_equal( - sldscResults(sd, "traitX", "joint")$categories, + .sldscRun(sd, "traitX", "joint")$categories, c("annot_A_0", "annot_B_0", "baselineLD_0") ) # whole single list when idx is NULL - expect_length(sldscResults(sd, "traitX", "single"), 2L) + expect_length(.sldscRun(sd, "traitX", "single"), 2L) # out-of-range idx -> NULL - expect_null(sldscResults(sd, "traitX", "single", 5L)) + expect_null(.sldscRun(sd, "traitX", "single", 5L)) # unknown trait -> NULL - expect_null(sldscResults(sd, "no_such_trait", "joint")) + expect_null(.sldscRun(sd, "no_such_trait", "joint")) }) -test_that("sldscResults returns NULL joint when a trait has none", { +test_that(".sldscRun returns NULL joint when a trait has none", { sd <- .sldscMkData(withJoint = FALSE) - expect_null(sldscResults(sd, "traitX", "joint")) + expect_null(.sldscRun(sd, "traitX", "joint")) + expect_null(sldscResults(sd, "traitX")[["traitX"]]$joint) }) test_that("show prints a compact summary", { diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index ca4767e8..91e2f497 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -13,7 +13,7 @@ context("causalInferencePipeline") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -83,7 +83,7 @@ context("causalInferencePipeline") entry = list(gr), genome = "hg19", ldReference = .cip_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } @@ -91,7 +91,7 @@ context("causalInferencePipeline") method = "susie", variant_ids = sprintf("chr1:%d:A:G", 100L * (1:5)) ) { - entry <- twasWeightsRow( + entry <- TwasWeightsRow( variantIds = variant_ids, weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) @@ -119,7 +119,7 @@ context("causalInferencePipeline") posterior_sd = rep(0.05, n), stringsAsFactors = FALSE ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = variant_ids, susieFit = list(), topLoci = tl @@ -173,7 +173,7 @@ test_that("causalInferencePipeline: rejects non-TwasWeights twasWeights arg", { }) test_that("causalInferencePipeline: rejects GwasFineMappingResult for the QTL slot", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame( @@ -207,7 +207,7 @@ test_that(".cipRequireMatchingLdRefs: NULL twas-side ldReference is allowed", { context = "c1", trait = "t1", method = "lasso", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), @@ -231,7 +231,7 @@ test_that(".cipRequireMatchingLdRefs: sample set mismatch errors", { context = "c1", trait = "t1", method = "lasso", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), @@ -250,16 +250,44 @@ 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. + tw <- .cip_makeTwasWeights() + tw <- pecotmr:::.withRowLdRefs(tw, .cip_makeHandle(snp_n = 6L)) + gwas <- pecotmr:::.withRowLdRefs( + .cip_makeGwasSumstats(), + .cip_makeHandle(snp_n = 7L) + ) expect_warning( expect_null(pecotmr:::.cipRequireMatchingLdRefs( - .cip_makeHandle(snp_n = 6L), - .cip_makeHandle(snp_n = 7L), + tw, + gwas, label = "twasWeights" )), "share 6 variant" ) }) +test_that(".cipRequireMatchingLdRefs: rows that never meet may differ", { + # The check is per pair of rows scored together -- those whose regions + # overlap -- so a weight row elsewhere on the genome is not held to the + # GWAS rows' panel. + elsewhere <- TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "lasso", + entry = list(TwasWeightsRow( + variantIds = sprintf("chr2:%d:A:G", 100L * (1:5)), + weights = rep(0.1, 5) + )), + ldReference = .cip_makeHandle(sample_prefix = "other") + ) + expect_null(pecotmr:::.cipRequireMatchingLdRefs( + elsewhere, + .cip_makeGwasSumstats(), + label = "twasWeights" + )) +}) + # =========================================================================== # Happy path: TwasWeights only # =========================================================================== @@ -339,11 +367,11 @@ test_that("causalInferencePipeline: combineMethods appends combined rows", { trait = c("t1", "t1"), method = c("lasso", "enet"), entry = list( - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.05, 5) ) @@ -381,7 +409,7 @@ test_that(".cipZToSe: falls back to vector of 1 when maf/n are NA", { test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, SS-TWAS keeps all", { mkEntry <- function(rsq, pval = 0.01) { - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = rep(0.1, 3), cvResult = list(metrics = c(corr = 0.1, rsq = rsq, pval = pval)) @@ -439,11 +467,11 @@ test_that(".cipFilterEligibleMethods: rsq+pval gating, drop sub-cutoff groups, S trait = rep("G", 2), method = c("susie", "lasso"), entry = list( - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = rep(0.1, 3) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = rep(0.1, 3) ) @@ -494,12 +522,12 @@ test_that("causalInferencePipeline: rsqCutoff selects the max-rsq method per gro trait = rep("t1", 2), method = c("susie", "lasso"), entry = list( - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = c(0.1, 0.05, -0.2, 0.3, 0.0), cvResult = list(metrics = c(rsq = 0.2, pval = 0.001)) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = c(0.2, 0.1, -0.1, 0.2, 0.1), cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) @@ -527,12 +555,12 @@ test_that("causalInferencePipeline: NA/Inf TWAS-Z triggers method re-selection", method = c("susie", "lasso"), entry = list( # top rsq but all-zero weights -> wᵀRw = 0 -> twasZ NaN - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0, 5), cvResult = list(metrics = c(rsq = 0.9, pval = 0.001)) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = c(0.2, 0.1, -0.1, 0.2, 0.1), cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) @@ -560,12 +588,12 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods trait = rep("t1", 2), method = c("susie", "lasso"), entry = list( - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = c(0.2, 0.1, -0.1, 0.2, 0.1), cvResult = list(metrics = c(rsq = 0.9, pval = 0.5)) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = c(0.2, 0.1, -0.1, 0.2, 0.1), cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) @@ -589,7 +617,7 @@ test_that("causalInferencePipeline: rsqPvalCutoff gates out high-CV-pval methods }) -context("twas: twasZ and harmonize deprecated wrappers") +context("twasZ") # =========================================================================== # Fixture builder: a small genotype + LD matrix. @@ -822,28 +850,48 @@ test_that("twasZ: combineMethods K>=2 forwards to combinePValues with correlatio expect_equal(res$combined$input$nValid, 2L) }) # =========================================================================== -# Tests migrated from test_twas.R (twasZ behaviour) +# twasZ: hand-computed values on the R path (positional alignment) # =========================================================================== -test_that("twasZ errors when weights and z lengths differ", { - expect_error(twasZ(c(1, 2), c(1, 2, 3)), "Must have exactly 3 rows") -}) - - -test_that("twasZ: single weight and single z-score returns valid result", { - weights <- 0.7 - z <- 2.5 - R <- matrix(1, nrow = 1, ncol = 1) - result <- twasZ(weights, z, R = R) - expect_true(is.list(result)) - expect_equal(colnames(result$Z), c("Z", "pval")) - # With single variant: stat = 0.7 * 2.5 = 1.75, denom = 0.7 * 1 * 0.7 = 0.49 - # zscore = 1.75 / sqrt(0.49) = 1.75 / 0.7 = 2.5 - expect_equal(as.numeric(result$Z[, "Z"]), 2.5, tolerance = 1e-10) - expect_true(result$Z[, "pval"] > 0 && result$Z[, "pval"] < 1) +test_that("twasZ: R path gives w'z / sqrt(w'Rw) on hand-computed cases", { + # Each case: weights, z, R and the Z worked out by hand. + cases <- list( + # 0.7 * 2.5 / sqrt(0.7^2) = 2.5 + singleVariant = list(0.7, 2.5, matrix(1), 2.5), + # 5 * 3 / sqrt(5) + equalWeights = list(rep(1, 5), rep(3, 5), diag(5), 15 / sqrt(5)), + # (-1 - 0.3) / sqrt(0.25 + 0.09): the sign follows the weights. + negativeWeights = list( + c(-0.5, -0.3), + c(2, 1), + diag(2), + -1.3 / sqrt(0.34) + ), + # w'Rw = sum(w)^2 = 1 when every pair is perfectly correlated. + perfectlyCorrelated = list(rep(0.25, 4), rep(2, 4), matrix(1, 4, 4), 2), + # A single non-zero weight reads that variant's z alone. + sparseWeights = list(c(0, 0, 1, 0, 0), 1:5, diag(5), 3), + # 1e6 * 1e-6 / sqrt(1e12) + largeWeightTinyZ = list(c(1e6, 0, 0), c(1e-6, 5, 5), diag(3), 1e-6), + # Z = 0, so the p-value is 1. + zeroZ = list(c(0.5, 0.3, 0.2), c(0, 0, 0), diag(3), 0), + # Z = 2e6 / sqrt(2), so the p-value underflows to 0. + largeZ = list(c(1, 1), c(1e6, 1e6), diag(2), 2e6 / sqrt(2)) + ) + for (nm in names(cases)) { + cs <- cases[[nm]] + res <- twasZ(cs[[1L]], cs[[2L]], R = cs[[3L]])$Z + expect_equal(colnames(res), c("Z", "pval"), info = nm) + expect_equal(unname(res[, "Z"]), cs[[4L]], tolerance = 1e-10, info = nm) + expect_equal( + unname(res[, "pval"]), + 2 * pnorm(-abs(cs[[4L]])), + tolerance = 1e-10, + info = nm + ) + } }) - test_that("twasZ: all-zero weights produce NaN z-score", { weights <- c(0, 0, 0) z <- c(1.5, -0.5, 2.0) @@ -854,68 +902,6 @@ test_that("twasZ: all-zero weights produce NaN z-score", { }) -test_that("twasZ: very large z-scores still produce finite results", { - set.seed(42) - p <- 5 - weights <- rnorm(p) - z <- rep(1e6, p) - R <- diag(p) - result <- twasZ(weights, z, R = R) - expect_true(is.finite(as.numeric(result$Z[, "Z"]))) - # p-value should be extremely small for large z - expect_true(result$Z[, "pval"] < 1e-10 || result$Z[, "pval"] == 0) -}) - - -test_that("twasZ: identical z-scores with equal weights gives proportional result", { - p <- 5 - weights <- rep(1, p) - z <- rep(3.0, p) - R <- diag(p) - result <- twasZ(weights, z, R = R) - # stat = sum(weights * z) = 5 * 3 = 15 - # denom = t(w) %*% I %*% w = 5 - # zscore = 15 / sqrt(5) = 6.7082... - expect_equal(as.numeric(result$Z[, "Z"]), 15 / sqrt(5), tolerance = 1e-10) -}) - - -test_that("twasZ: negative weights flip the sign of the z-score", { - weights_pos <- c(0.5, 0.3) - weights_neg <- c(-0.5, -0.3) - z <- c(2.0, 1.0) - R <- diag(2) - result_pos <- twasZ(weights_pos, z, R = R) - result_neg <- twasZ(weights_neg, z, R = R) - # z-score should have opposite sign but same p-value - expect_equal( - as.numeric(result_pos$Z[, "Z"]), - -as.numeric(result_neg$Z[, "Z"]), - tolerance = 1e-10 - ) - expect_equal( - as.numeric(result_pos$Z[, "pval"]), - as.numeric(result_neg$Z[, "pval"]), - tolerance = 1e-10 - ) -}) - - -test_that("twasZ: off-diagonal correlation in R changes the result", { - weights <- c(0.5, 0.5) - z <- c(2.0, 2.0) - R_identity <- diag(2) - R_correlated <- matrix(c(1, 0.8, 0.8, 1), nrow = 2) - result_identity <- twasZ(weights, z, R = R_identity) - result_correlated <- twasZ(weights, z, R = R_correlated) - # Same stat but different denominators, so different z-scores - expect_false(isTRUE(all.equal( - as.numeric(result_identity$Z[, "Z"]), - as.numeric(result_correlated$Z[, "Z"]) - ))) -}) - - test_that("twasZ: computing R from X matches providing R directly", { set.seed(123) n <- 20 @@ -939,102 +925,6 @@ test_that("twasZ: computing R from X matches providing R directly", { ) }) - -test_that("twasZ: p-value is always between 0 and 1 for random inputs", { - set.seed(999) - for (i in 1:5) { - p <- sample(2:10, 1) - weights <- rnorm(p) - z <- rnorm(p) - R <- diag(p) # use identity to avoid singularity - result <- twasZ(weights, z, R = R) - pval <- as.numeric(result$Z[, "pval"]) - expect_true( - pval >= 0 && pval <= 1, - info = paste("Iteration", i, "p-value out of range:", pval) - ) - } -}) - - -test_that("twasZ: single very large weight with tiny z gives moderate result", { - weights <- c(1e6, 0, 0) - z <- c(1e-6, 5.0, 5.0) - R <- diag(3) - result <- twasZ(weights, z, R = R) - # stat = 1e6 * 1e-6 + 0 + 0 = 1.0 - # denom = (1e6)^2 * 1 = 1e12 - # zscore = 1 / sqrt(1e12) = 1e-6 - expect_equal(as.numeric(result$Z[, "Z"]), 1e-6, tolerance = 1e-10) -}) - -# =========================================================================== -# twasZ: more mathematical edge cases -# =========================================================================== - -test_that("twasZ: perfectly correlated R matrix (all ones off-diagonal)", { - p <- 4 - R <- matrix(1, nrow = p, ncol = p) # perfectly correlated - weights <- c(0.25, 0.25, 0.25, 0.25) - z <- c(2, 2, 2, 2) - result <- twasZ(weights, z, R = R) - # stat = sum(0.25 * 2) = 2 - # denom = t(w) %*% ones_matrix %*% w = (sum(w))^2 = 1 - # zscore = 2 / sqrt(1) = 2 - expect_equal(as.numeric(result$Z[, "Z"]), 2.0, tolerance = 1e-10) -}) - - -test_that("twasZ: sparse weights (only one non-zero) extracts single SNP signal", { - p <- 5 - weights <- c(0, 0, 1, 0, 0) - z <- c(1, 2, 3, 4, 5) - R <- diag(p) - result <- twasZ(weights, z, R = R) - # With identity R and sparse weight: zscore = w3 * z3 / sqrt(w3^2) = 3 - expect_equal(as.numeric(result$Z[, "Z"]), 3.0, tolerance = 1e-10) -}) - - -test_that("twasZ: z-scores of zero give zero TWAS z-score", { - weights <- c(0.5, 0.3, 0.2) - z <- c(0, 0, 0) - R <- diag(3) - result <- twasZ(weights, z, R = R) - expect_equal(as.numeric(result$Z[, "Z"]), 0.0, tolerance = 1e-10) - # p-value for z=0 should be 1 - expect_equal(as.numeric(result$Z[, "pval"]), 1.0, tolerance = 1e-10) -}) - -# =========================================================================== -# twasZ: edge case with near-singular R matrix -# =========================================================================== - -test_that("twasZ: near-singular R matrix still produces a result", { - set.seed(777) - p <- 3 - # Create a nearly singular R by making two rows almost identical - R <- matrix(c(1, 0.999, 0.999, 0.999, 1, 0.999, 0.999, 0.999, 1), nrow = 3) - weights <- c(0.3, 0.4, 0.3) - z <- c(2.0, 2.5, 1.8) - result <- twasZ(weights, z, R = R) - expect_true(is.list(result)) - expect_true(is.finite(as.numeric(result$Z[, "Z"]))) -}) - - -test_that("twasZ: length-one input vectors produce correct scalar output", { - result <- twasZ(1.0, 3.0, R = matrix(1, 1, 1)) - expect_equal(as.numeric(result$Z[, "Z"]), 3.0, tolerance = 1e-10) - expect_true(result$Z[, "pval"] > 0 && result$Z[, "pval"] < 1) -}) - - -test_that("twasZ: R=NULL and X=NULL still errors consistently", { - # When neither R nor X is provided, twasZ should error - expect_error(twasZ(c(1, 2), c(3, 4))) -}) - # =========================================================================== # twasZ: matrix weights path -- multiple methods/conditions # =========================================================================== @@ -1058,140 +948,40 @@ test_that("twasZ: matrix weights produce one Z row per column", { }) -test_that("twasZ: combineMethods returns combined p-value summary", { - set.seed(11) - p <- 4 - k <- 2 - weights <- matrix( - rnorm(p * k), - nrow = p, - ncol = k, - dimnames = list(paste0("SNP", seq_len(p)), paste0("Cond", seq_len(k))) - ) - z <- rnorm(p) - R <- diag(p) - rownames(R) <- colnames(R) <- paste0("SNP", seq_len(p)) - result <- twasZ(weights, z, R = R, combineMethods = "acat") - expect_false(is.null(result$combined)) -}) - -# =========================================================================== -# Tests from test_twas_predict.R -# =========================================================================== - -# ---- twasPredict ---- - # =========================================================================== -# Tests migrated from test_twasSketch.R (twasZ SVD path) +# twasZ: the SVD path agrees with the R path # =========================================================================== -test_that("twasZ: SVD path matches R path for full-rank genotype matrix", { - set.seed(42) - n <- 100 # samples (sketch size) - p <- 20 # variants - - # Generate genotype-like matrix (dosages 0/1/2) - X <- matrix(rbinom(n * p, 2, runif(p, 0.1, 0.9)), nrow = n, ncol = p) - - # HWE-based standardization - af <- colMeans(X) / 2 - X_std <- sweep(X, 2, 2 * af) - X_std <- sweep(X_std, 2, sqrt(2 * af * (1 - af)), "/") - - # Compute R from standardized X - R <- crossprod(X_std) / (n - 1) - - # SVD of standardized X - svd_result <- svd(X_std) - - # Random weights and z-scores - weights <- rnorm(p) - z <- rnorm(p) - - # R path - result_R <- pecotmr:::twasZ(weights, z, R = R) - - # SVD path - result_SVD <- pecotmr:::twasZ( - weights, - z, - V = svd_result$v, - D = svd_result$d, - nSketch = n - ) - - expect_equal( - as.numeric(result_SVD$z), - as.numeric(result_R$z), - tolerance = 1e-10 - ) - expect_equal( - as.numeric(result_SVD$pval), - as.numeric(result_R$pval), - tolerance = 1e-10 - ) -}) - - -test_that("twasZ: SVD path matches R path for rank-deficient matrix (n < p)", { - set.seed(123) - n <- 15 # fewer samples than variants - - p <- 30 - - X <- matrix(rbinom(n * p, 2, runif(p, 0.15, 0.85)), nrow = n, ncol = p) - - af <- colMeans(X) / 2 - # Remove monomorphic columns - keep <- af > 0 & af < 1 - X <- X[, keep, drop = FALSE] - af <- af[keep] - p <- ncol(X) - - X_std <- sweep(X, 2, 2 * af) - X_std <- sweep(X_std, 2, sqrt(2 * af * (1 - af)), "/") - - R <- crossprod(X_std) / (n - 1) - svd_result <- svd(X_std) - - weights <- rnorm(p) - z <- rnorm(p) - - result_R <- pecotmr:::twasZ(weights, z, R = R) - result_SVD <- pecotmr:::twasZ( - weights, - z, - V = svd_result$v, - D = svd_result$d, - nSketch = n - ) - - expect_equal( - as.numeric(result_SVD$z), - as.numeric(result_R$z), - tolerance = 1e-10 - ) - expect_equal( - as.numeric(result_SVD$pval), - as.numeric(result_R$pval), - tolerance = 1e-10 - ) +test_that("twasZ: SVD path matches R path, full rank and n < p", { + # Sketch sizes (samples, variants, seed): full rank, and fewer samples + # than variants. + shapes <- list(fullRank = c(100, 20, 42), rankDeficient = c(15, 30, 123)) + for (nm in names(shapes)) { + n <- shapes[[nm]][[1L]] + p <- shapes[[nm]][[2L]] + set.seed(shapes[[nm]][[3L]]) + X <- matrix(rbinom(n * p, 2, runif(p, 0.15, 0.85)), nrow = n, ncol = p) + af <- colMeans(X) / 2 + # A monomorphic column has no standardized dosage. + keep <- af > 0 & af < 1 + X <- X[, keep, drop = FALSE] + af <- af[keep] + Xstd <- sweep(X, 2, 2 * af) + Xstd <- sweep(Xstd, 2, sqrt(2 * af * (1 - af)), "/") + R <- crossprod(Xstd) / (n - 1) + s <- svd(Xstd) + weights <- rnorm(ncol(X)) + z <- rnorm(ncol(X)) + expect_equal( + twasZ(weights, z, V = s$v, D = s$d, nSketch = n)$Z, + twasZ(weights, z, R = R)$Z, + tolerance = 1e-10, + info = nm + ) + } }) -test_that("twasZ: error when weights and z have different lengths", { - expect_error( - pecotmr:::twasZ( - rnorm(5), - rnorm(3), - V = matrix(1, 5, 2), - D = c(1, 1), - nSketch = 10 - ), - "weights.*Must have exactly 3 rows" - ) -}) - # =========================================================================== # Direct unit tests for the MR / metric helpers (mock topLoci to feed # controlled topLoci frames; gwasDf is a plain data.frame as produced by @@ -1398,7 +1188,7 @@ test_that(".cipComputeMrCsAware matches across a chr-prefix difference", { test_that(".cipComputeTwasZ gives a Z from a panel's factor or an LdMatrix", { data(gwasSumStatsS4Example) - panel <- ldReference(gwasSumStatsS4Example) + panel <- ldReference(gwasSumStatsS4Example)[[1L]] ids <- names(SummarizedExperiment::rowRanges(panel))[c(3, 8, 15, 21, 30)] ld <- LdMatrix( unname(computeLd(panel)), @@ -1798,8 +1588,7 @@ test_that(".cipComputeTwasZ: below 2 matches warns instead of silent NULL", { expect_null(out) }) -test_that(".cipComputeTwasZ: full overlap is silent", { - ids <- paste0("chr1:", 100 * (1:3), ":A:G") +test_that(".cipWarnVariantDrop: a full overlap is silent", { expect_silent( pecotmr:::.cipWarnVariantDrop(3L, 3L, "test pair") ) @@ -1977,7 +1766,7 @@ test_that(".cipRun errors when no tuple produced a result", { selectionActive = FALSE ) }, - .cipScoreQtlTuple = function(qi, ...) list(), + .cipTupleInputs = function(...) NULL, .package = "pecotmr" ) expect_error( @@ -1994,30 +1783,75 @@ test_that(".cipRun errors when no tuple produced a result", { ) }) -test_that(".cipScoreQtlTuple skips a tuple with no weights", { +test_that(".cipTupleInputs skips a tuple with no weights", { local_mocked_bindings( .cipExtractWeights = function(...) NULL, .package = "pecotmr" ) - p <- list( - qtlRows = data.frame( - qtlStudy = "s", - context = "c", - trait = "t", - method = "m", - useFmrForWeights = FALSE, - stringsAsFactors = FALSE + qtlRows <- data.frame( + qtlStudy = "s", + context = "c", + trait = "t", + method = "m", + useFmrForWeights = FALSE, + stringsAsFactors = FALSE + ) + expect_null(pecotmr:::.cipTupleInputs(1L, qtlRows, NULL, NULL)) +}) + +test_that("causalInferencePipeline refuses a tuple past given blocks", { + # The block window ends before chr1:500, which a weight sits on. + gws <- suppressWarnings(GwasSumStats( + studyName = "G1", + entry = list(sumStats(.cip_makeGwasSumstats())), + genome = "hg19", + ldReference = .cip_makeHandle(), + qcOptions = list(step1 = "ok"), + region = GenomicRanges::GRanges("chr1:1-450") + )) + expect_error( + causalInferencePipeline( + gwasSumStats = gws, + twasWeights = .cip_makeTwasWeights() + ), + "1 variant(s) past the end of block chr1:1-450 of GWAS study 'G1'", + fixed = TRUE + ) +}) + +test_that(".cipCheckBlockReach warns of a tuple running past computed spans", { + gws <- GwasSumStats( + studyName = "G1", + entry = list(sumStats(.cip_makeGwasSumstats())[1:3]), + genome = "hg19" + ) + tuple <- list( + tuple = list( + qStudy = "Q1", + qContext = "c1", + qTrait = "t1", + qMethod = "m" + ), + variants = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:5), width = 1L) + ) + ) + expect_warning( + pecotmr:::.cipCheckBlockReach(list(tuple), gws), + str_c( + "QTL (study='Q1', context='c1', trait='t1', method='m'): ", + "2 variant(s) past the end of block chr1 (chr1:100-300)" ), - twasWeights = NULL, - fineMappingResult = NULL + fixed = TRUE ) - # An empty list contributes no rows once flattened. - expect_identical(pecotmr:::.cipScoreQtlTuple(1L, p), list()) }) test_that(".cipScoreGwasPair skips a pair with no TWAS z", { local_mocked_bindings( - as.data.frame = function(...) data.frame(SNP = "v1", Z = 1), + .cipRowsLdRef = function(...) NULL, + .ssStitchElements = function(...) GenomicRanges::GRanges(), + .entryToSumstatDf = function(...) data.frame(SNP = "v1", Z = 1), .cipComputeTwasZ = function(...) NULL, .cipPairLabel = function(...) "lab", .package = "pecotmr" @@ -2025,11 +1859,12 @@ test_that(".cipScoreGwasPair skips a pair with no TWAS z", { expect_null( pecotmr:::.cipScoreGwasPair( 1L, + "G1", NULL, list(), NULL, - gwasSumStats = list(study = "G1"), - gwasLd = NULL, + gwasSumStats = NULL, + window = NULL, alleleFlip = FALSE, mrParam = MrParam( method = "csAware", @@ -2055,23 +1890,95 @@ test_that(".cipRunMr routes to the CS-aware estimator when asked", { expect_true(isTRUE(out$SENTINEL)) }) -test_that(".cipCvMetric reads metrics wrapped or bare, NA when absent", { - local_mocked_bindings( - cvResult = function(...) list(rsq = 0.42, pval = 0.01), - .package = "pecotmr" +# One-row weights for (Q1, c1, t1, susie) whose cross-validation is `cv`. +.cip_cvWeights <- function(cv) { + TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), + weights = c(0.1, 0.05, -0.2, 0.3, 0.0), + cvResult = cv + )) ) +} + +test_that(".cipCvMetric reads metrics wrapped or bare, NA when absent", { # A bare metrics list (no $metrics wrapper) is read directly. - expect_equal(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq"), 0.42) - expect_true(is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "zzz"))) + bare <- .cip_cvWeights(list(rsq = 0.42, pval = 0.01)) + expect_equal( + pecotmr:::.cipCvMetric(bare, "Q1", "c1", "t1", "susie", "rsq"), + 0.42 + ) + expect_true(is.na( + pecotmr:::.cipCvMetric(bare, "Q1", "c1", "t1", "susie", "zzz") + )) + wrapped <- .cip_cvWeights(list(metrics = c(rsq = 0.3, pval = 0.02))) + expect_equal( + pecotmr:::.cipCvMetric(wrapped, "Q1", "c1", "t1", "susie", "pval"), + 0.02 + ) }) test_that(".cipCvMetric returns NA when the CV result cannot be read", { + # No row for the tuple; and a row without a CV record. + tw <- .cip_cvWeights(list(rsq = 0.42)) + expect_true( + is.na(pecotmr:::.cipCvMetric(tw, "Q9", "c1", "t1", "susie", "rsq")) + ) + expect_true(is.na( + pecotmr:::.cipCvMetric( + .cip_cvWeights(NULL), + "Q1", + "c1", + "t1", + "susie", + "rsq" + ) + )) +}) + +test_that("CV selection warns once about narrowed weights; scoring does not", { + tw <- TwasWeights( + studyName = rep("Q1", 2), + context = rep("c1", 2), + trait = rep("t1", 2), + method = c("susie", "lasso"), + entry = list( + TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), + weights = c(0.1, 0.05, -0.2, 0.3, 0.0), + cvResult = list(metrics = c(rsq = 0.2, pval = 0.001)) + ), + TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), + weights = c(0.2, 0.1, -0.1, 0.2, 0.1), + cvResult = list(metrics = c(rsq = 0.5, pval = 0.001)) + ) + ), + ldReference = .cip_makeHandle() + ) + narrowed <- endoapply(tw, utils::head, 4L) local_mocked_bindings( - cvResult = function(...) stop("nope"), + extractBlockGenotypes = .cip_mockExtractor(), .package = "pecotmr" ) - expect_true( - is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq")) + selected <- .fitCoverageMessages(causalInferencePipeline( + gwasSumStats = .cip_makeGwasSumstats(), + twasWeights = narrowed, + weightSelectionParam = WeightSelectionParam(cutoff = 0.1) + )) + expect_length(selected, 1L) + expect_match(selected, "causalInferencePipeline\\(\\): 2 row\\(s\\)") + # Without selection only the weights are read, which the row holds. + expect_length( + .fitCoverageMessages(causalInferencePipeline( + gwasSumStats = .cip_makeGwasSumstats(), + twasWeights = narrowed + )), + 0L ) }) @@ -2126,3 +2033,97 @@ test_that("WeightSelectionParam and MrParam do not overlap", { expect_equal(WeightSelectionParam()$cutoff, 0) expect_equal(MrParam()$method, "ivwPerVariant") }) + +test_that(".cipRowsLdRef refuses overlapped rows on two references", { + # The rows a tuple overlaps are scored together against one LD matrix. + block <- function(start) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(seq(start, by = 100L, length.out = 3L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf( + "chr1:%d:A:G", + seq(start, by = 100L, length.out = 3L) + ), + A1 = "A", + A2 = "G", + Z = c(1, 2, 3), + N = 1000L + ) + gr + } + two <- GwasSumStats( + studyName = c("G1", "G1"), + entry = list(block(100L), block(5000L)), + genome = "hg19", + ldReference = list( + .cip_makeHandle(), + .cip_makeHandle(sample_prefix = "z") + ), + blockId = c("b1", "b2"), + qcOptions = list(step1 = "ok") + ) + expect_error( + pecotmr:::.cipRowsLdRef(two, 1:2, "G1"), + "GWAS study 'G1' a QTL tuple overlaps use 2 different LD" + ) + # A tuple overlapping one of them reads that row's reference alone. + expect_identical( + pecotmr:::.cipRowsLdRef(two, 2L, "G1"), + ldReference(two)[[2L]] + ) +}) + +test_that("a gene is scored once per GWAS study, over the rows it overlaps", { + # One study split into two LD blocks on chr1 plus a chr2 row on another + # panel: the chr1 gene overlaps only block A, so it is scored once, + # and the chr2 row's reference never enters into it. + idsA <- sprintf("chr1:%d:A:G", 100L * (1:5)) + idsB <- sprintf("chr1:%d:A:G", 100L * (6:10)) + ids2 <- sprintf("chr2:%d:A:G", 100L * (1:5)) + ldm <- function(ids) { + n <- length(ids) + LdMatrix(`dimnames<-`(diag(n) * 0.5 + 0.5, list(ids, ids))) + } + entry <- function(ids, chrom, pos) { + gr <- GenomicRanges::GRanges(chrom, IRanges::IRanges(pos, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = ids, + A1 = "A", + A2 = "G", + Z = seq(4, 0.5, length.out = length(ids)), + N = 1000L + ) + gr + } + chr1 <- ldm(c(idsA, idsB)) + gws <- GwasSumStats( + studyName = c("G1", "G1", "G1"), + entry = list( + entry(idsA, "chr1", 100L * (1:5)), + entry(idsB, "chr1", 100L * (6:10)), + entry(ids2, "chr2", 100L * (1:5)) + ), + genome = "hg19", + ldReference = list(chr1, chr1, ldm(ids2)), + blockId = c("blockA", "blockB", "chr2"), + qcOptions = list(step1 = "ok") + ) + tw <- TwasWeights( + studyName = "Q1", + context = "c1", + trait = "gene1", + method = "lasso", + entry = list(TwasWeightsRow( + variantIds = idsA, + weights = c(0.3, 0.2, 0.1, 0.05, 0) + )), + ldReference = chr1 + ) + out <- suppressMessages(suppressWarnings( + causalInferencePipeline(gwasSumStats = gws, twasWeights = tw) + )) + expect_equal(length(out), 1L) + expect_equal(as.character(S4Vectors::mcols(out)$gwasStudy), "G1") +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 9ebfc83a..948c878f 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -14,7 +14,7 @@ context("colocPipeline") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -68,7 +68,7 @@ context("colocPipeline") dimnames = list(NULL, variant_ids) ) } - fineMappingRow(variantIds = variant_ids, susieFit = fit, topLoci = tl) + FineMappingRow(variantIds = variant_ids, susieFit = fit, topLoci = tl) } .cp_makeQtlFmr <- function( @@ -133,7 +133,7 @@ context("colocPipeline") entry = list(gr), genome = "hg19", ldReference = .cp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } @@ -159,7 +159,7 @@ context("colocPipeline") entry = list(gr), genome = "hg19", ldReference = .cp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } @@ -263,11 +263,16 @@ test_that(".colocRequireMatchingLdRefs: sample set mismatch errors", { 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. + qfmr <- pecotmr:::.withRowLdRefs( + .cp_makeQtlFmr(), + .cp_makeHandle(snp_n = 6L) + ) + gfmr <- pecotmr:::.withRowLdRefs( + .cp_makeGwasFmr(), + .cp_makeHandle(snp_n = 7L) + ) expect_warning( - expect_null(pecotmr:::.colocRequireMatchingLdRefs( - .cp_makeHandle(snp_n = 6L), - .cp_makeHandle(snp_n = 7L) - )), + expect_null(pecotmr:::.colocRequireMatchingLdRefs(qfmr, gfmr)), "share 6 variant" ) }) @@ -295,6 +300,43 @@ test_that("colocPipeline: returns one row per (QTL tuple, GWAS tuple) pair", { expect_setequal(out$gwasStudy, c("G1", "G2")) }) +test_that("colocPipeline carries the sides' genome build and refuses two", { + qfmr <- .cp_makeQtlFmr() + gfmr <- GenomeInfoDb::`genome<-`(.cp_makeGwasFmr(), value = "hg38") + # Per-variant results too, so the pair holds variants for seqinfo to + # describe: a collection of empty elements has no sequence to name a + # build for. + summaryOnly <- .cp_mockColocBfBf() + local_mocked_bindings( + coloc.bf_bf = function(qLbf, gLbf, ...) { + res <- summaryOnly(qLbf, gLbf, ...) + # The LBF matrices carry a `null` column beside the variants. + ids <- colnames(qLbf)[str_detect(colnames(qLbf), ":")] + res$results <- data.frame( + snp = ids, + SNP.PP.H4.row1 = 1 / length(ids) + ) + res + }, + .package = "coloc" + ) + out <- suppressWarnings(colocPipeline( + qtlFineMappingResult = qfmr, + gwasInput = gfmr + )) + expect_gt(sum(lengths(out)), 0L) + expect_identical(unique(unname(GenomeInfoDb::genome(out))), "hg38") + expect_identical( + unique(unname(GenomeInfoDb::genome(colocVariants(out)))), + "hg38" + ) + hg19 <- GenomeInfoDb::`genome<-`(qfmr, value = "hg19") + expect_error( + colocPipeline(qtlFineMappingResult = hg19, gwasInput = gfmr), + "colocPipeline: the inputs name different genome builds" + ) +}) + # =========================================================================== # Either side may be a QTL or a GWAS fine-mapping result # =========================================================================== @@ -387,8 +429,14 @@ test_that("colocPipeline: resolves GwasSumStats via fineMappingPipeline (mocked) qfmr <- .cp_makeQtlFmr() gss <- .cp_makeGwasSumstats() local_mocked_bindings(coloc.bf_bf = .cp_mockColocBfBf(), .package = "coloc") + # Like the real pipeline, the stand-in keeps each row's block name, which + # is what the pairing finds a region's fit by. local_mocked_bindings( - fineMappingPipeline = function(data, methods, ...) .cp_makeGwasFmr(), + fineMappingPipeline = function(data, methods, ...) { + fmr <- .cp_makeGwasFmr() + fmr$blockId <- as.character(data$blockId) + fmr + }, .package = "pecotmr" ) out <- suppressWarnings(colocPipeline( @@ -460,7 +508,7 @@ test_that("colocPipeline: empty result has the documented schema", { V = 0, lbf_variable = matrix(NA_real_, 1, 1) ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = shared, susieFit = emptyFit, topLoci = data.frame( @@ -502,7 +550,8 @@ test_that("colocPipeline: empty result has the documented schema", { "PP.H3.abf", "PP.H4.abf", "qtlRetainedMass", - "gwasRetainedMass" + "gwasRetainedMass", + "ldReference" ) ) }) @@ -511,8 +560,8 @@ test_that("colocPipeline: empty result has the documented schema", { # Internal helpers # =========================================================================== -test_that(".colocExtractLbfFromEntry: entry without trimmedFit returns NULL with warning", { - e <- fineMappingRow( +test_that(".colocExtractLbfFromEntry: refuses an entry with no retained fit", { + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = NULL, topLoci = data.frame( @@ -552,7 +601,7 @@ test_that(".colocExtractLbfFromEntry: filterLbfCs subsets by cs_index", { ), sets = list(cs_index = c(1L, 3L)) ) # keep effects 1 and 3 - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), susieFit = fit, topLoci = data.frame( @@ -616,21 +665,8 @@ test_that(".colocStandardiseRow: fills in missing PP columns with NA", { )) }) - -context("encoloc") - -# The file-path colocalization / enrichment wrappers (colocWrapper, -# xqtlEnrichmentWrapper, colocPostProcessor) and their helpers -# (filterAndOrderColocResults, calculateCumsum, calculate_purity, -# processColocResults, extract_ld_for_variants) have been removed in -# favor of the S4 colocPipeline / qtlEnrichmentPipeline / enlocPipeline -# entry points. The previous tests against the file-path wrappers no -# longer apply; they relied on mocking rssAnalysisPipeline (also -# removed). New tests for colocPipeline / qtlEnrichmentPipeline / -# enlocPipeline live alongside their pipeline implementations. - # =========================================================================== -# .colocLookupEnrichment (formerly .enlocLookupEnrichment, now shared) +# .colocLookupEnrichment # =========================================================================== test_that(".colocLookupEnrichment: returns the value for a (gwasStudy, qtlStudy, qtlContext) hit", { @@ -675,7 +711,7 @@ test_that(".colocLookupEnrichment: returns NA when no row matches", { }) # =========================================================================== -# .colocEmptyResult(enriched = TRUE) — formerly .enlocEmptyResult +# .colocEmptyResult(enriched = TRUE) # =========================================================================== test_that(".colocEmptyResult(enriched=TRUE): includes enrichment + p12Used schema", { @@ -734,7 +770,7 @@ test_that("colocPipeline: rejects enrichment missing required columns", { # --- enrichment end-to-end (lookup + p12 scaling + output columns) ---------- -test_that("colocPipeline: enrichment mode takes its priors from the table", { +test_that("colocPipeline: enrichment takes table priors and reports RCP/LCP", { qfmr <- .cp_makeQtlFmr() # Q1 / c1 / t1 / susie gfmr <- .cp_makeGwasFmr() # G1 / susie enr <- data.frame( @@ -764,26 +800,7 @@ test_that("colocPipeline: enrichment mode takes its priors from the table", { # qtlEnrichmentPipeline derives p12 = P_eqtl * expit(a0 + a1) the way # fastenloc does; the pipeline uses that, rather than scaling a default. expect_equal(unique(out$p12Used), 2.5e-5) -}) - -test_that("enrichment mode reports RCP and LCP alongside the hypotheses", { - qfmr <- .cp_makeQtlFmr() - gfmr <- .cp_makeGwasFmr() - enr <- data.frame( - gwasStudy = "G1", - qtlStudy = "Q1", - qtlContext = "c1", - enrichment = 2.0, - colocP1 = 3e-4, - colocP2 = 7e-4, - colocP12 = 2.5e-5, - stringsAsFactors = FALSE - ) - out <- suppressWarnings(colocPipeline( - qtlFineMappingResult = qfmr, - gwasInput = gfmr, - enrichment = enr - )) + # RCP and LCP are reported alongside the hypotheses. pairs <- colocPairs(out) expect_true(all(c("RCP", "LCP") %in% colnames(pairs))) # The two names for the same quantities: fastenloc's RCP is the posterior @@ -905,7 +922,7 @@ test_that("colocPipeline: an enrichment miss warns and drops to plain priors", { expect_equal(unique(out$p12Used), 5e-6) }) -# --- returnGwasFineMapping attached on the empty-pair early return (~205) ---- +# --- returnGwasFineMapping attached on the empty-pair early return ---------- test_that("colocPipeline: attaches gwasFineMapping when no pairs survive", { qfmr <- .cp_makeQtlFmr() @@ -918,7 +935,7 @@ test_that("colocPipeline: attaches gwasFineMapping when no pairs survive", { V = 0, lbf_variable = matrix(NA_real_, 1, 1) ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = emptyFit, topLoci = .cp_tl("chr1:100:A:G", pip = 0) @@ -946,7 +963,7 @@ test_that("colocPipeline: attaches gwasFineMapping when no pairs survive", { expect_identical(attr(out, "gwasFineMapping"), resolved) }) -# --- per-pair loop skips: no usable QTL LBF (~223) and no overlap (~233) ----- +# --- per-pair loop skips: no usable QTL LBF and no overlap ------------------- test_that("colocPipeline: skips a QTL entry with no usable LBF", { badFit <- list( @@ -955,7 +972,7 @@ test_that("colocPipeline: skips a QTL entry with no usable LBF", { V = 0, lbf_variable = matrix(NA_real_, 1, 1) ) - badEntry <- fineMappingRow( + badEntry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = badFit, topLoci = .cp_tl("chr1:100:A:G", pip = 0) @@ -1002,7 +1019,7 @@ test_that("colocPipeline: skips a pair with no shared variants", { expect_equal(nrow(out), 0L) }) -# --- .colocFilterCsByConcentration (~324-331) ------------------------------- +# --- .colocFilterCsByConcentration ----------------------------------------- test_that(".colocFilterCsByConcentration: keeps narrow CS, drops diffuse ones", { fit <- list(alpha = matrix(0.1, nrow = 3, ncol = 10)) # 10 variants @@ -1043,7 +1060,7 @@ test_that(".colocExtractLbfFromEntry: stacks fSuSiE lBF list into a matrix", { dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (1:4))) ) fit <- list(fsusie_result = list(lBF = list(m1, m2))) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -1068,7 +1085,7 @@ test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (1:4))) ) fit <- list(list(fsusie_result = list(lBF = list(m1)))) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -1086,7 +1103,7 @@ test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", test_that(".colocExtractLbfFromEntry: refuses a fit carrying no LBF slot", { fit <- list(notLbf = list(a = 1)) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = fit, topLoci = .cp_tl("chr1:100:A:G") @@ -1126,7 +1143,7 @@ test_that(".colocExtractLbfFromEntry: refuses an empty LBF matrix", { dimnames = list(NULL, sprintf("chr1:%d:A:G", 100L * (1:3))) ) ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:3))) @@ -1154,7 +1171,7 @@ test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { ), alpha = matrix(0.25, 3, 4) ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -1179,7 +1196,7 @@ test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { test_that(".colocExtractLbfFromEntry: assigns colnames from variantIds when fit lacks them", { fit <- list(lbf_variable = matrix(1:8, 2, 4)) # no dimnames - e <- fineMappingRow( + e <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:4))) @@ -1206,7 +1223,7 @@ test_that(".colocExtractLbfFromEntry: NULL when every variant column is NA-named ) # variantIds length (1) != ncol (4) so colnames are NOT back-filled, and the # NA-named columns are dropped, leaving a 0-column matrix. - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = fit, topLoci = .cp_tl("chr1:100:A:G") @@ -1222,7 +1239,7 @@ test_that(".colocExtractLbfFromEntry: NULL when every variant column is NA-named expect_null(out) }) -# --- .colocAlignLbf no-overlap branch (~479) -------------------------------- +# --- .colocAlignLbf no-overlap branch -------------------------------------- test_that(".colocAlignLbf: returns NULL when there are no shared variants", { q <- matrix( @@ -1502,17 +1519,13 @@ test_that("priors and enrichment cannot both be given", { ), "cannot both be given" ) - # Either alone is fine. + # Either alone is fine; the same table alone is the enrichment-mode run + # tested above. expect_no_error(suppressWarnings(colocPipeline( qtlFineMappingResult = qfmr, gwasInput = gfmr, priors = ColocPriorParam(p12 = 1e-5) ))) - expect_no_error(suppressWarnings(colocPipeline( - qtlFineMappingResult = qfmr, - gwasInput = gfmr, - enrichment = enr - ))) }) test_that("GwasFineMappingParam carries only what the inline fit can use", { @@ -1584,28 +1597,27 @@ test_that("GwasFineMappingParam accessors round-trip a nested bundle", { expect_equal(fineMappingMethods(g), "susie") expect_s4_class(credibleSetParam(g), "CredibleSetParam") - # Why this class has accessors at all: once CredibleSetParam is - # settable, the container must let the edited record back in, or the - # nested settings would be readable but not writable. + # The container must let an edited nested record back in, or the nested + # settings would be readable but not writable. g2 <- g - cs <- credibleSetParam(g2) - csCoverage(cs) <- 0.8 - credibleSetParam(g2) <- cs + cs <- g2$credibleSetParam + cs$coverage <- 0.8 + g2$credibleSetParam <- cs expect_equal(csCoverage(credibleSetParam(g2)), 0.8) expect_equal(csCoverage(credibleSetParam(g)), 0.95) # The nested slots are typed, so the wrong Param is refused rather than # surfacing as a missing field somewhere downstream. expect_error( - susieRssParam(g) <- CredibleSetParam(), - "not valid for @.+susieRssParam" + g$susieRssParam <- CredibleSetParam(), + "susieRssParam" ) g3 <- g - susieRssParam(g3) <- SusieRssParam(serFallback = TRUE) + g3$susieRssParam <- SusieRssParam(serFallback = TRUE) expect_s4_class(g3, "GwasFineMappingParam") }) -test_that("GwasFineMappingParam accessors read and replace every field", { +test_that("GwasFineMappingParam fields read and replace, each one", { # Dispatching each accessor is what exercises the generics declared in # AllGenerics.R; the constructor alone never reaches them. p <- GwasFineMappingParam() @@ -1618,10 +1630,10 @@ test_that("GwasFineMappingParam accessors read and replace every field", { # Replacement edits a copy and leaves the original alone. edited <- p - fineMappingMethods(edited) <- "susieInf" - initializeWithSusieInf(edited) <- FALSE - fitRetention(edited) <- "full" - panelFilterParam(edited) <- PanelFilterParam() + edited$methods <- "susieInf" + edited$initializeWithSusieInf <- FALSE + edited$fitRetention <- "full" + edited$panelFilterParam <- PanelFilterParam() expect_equal(fineMappingMethods(edited), "susieInf") expect_false(initializeWithSusieInf(edited)) expect_equal(fitRetention(edited), "full") @@ -1629,3 +1641,553 @@ test_that("GwasFineMappingParam accessors read and replace every field", { expect_equal(fineMappingMethods(p), "susie") expect_true(initializeWithSusieInf(p)) }) + +# =========================================================================== +# Per-pair LD references +# =========================================================================== + +# An LdMatrix over five variants at 100 bp spacing on `chrom`. +.cp_ldm <- function(rho, chrom = "chr1") { + ids <- sprintf("%s:%d:A:G", chrom, 100L * (1:5)) + LdMatrix(`dimnames<-`(rho^abs(outer(1:5, 1:5, "-")), list(ids, ids))) +} + +test_that("coloc refuses an overlapping pair on two different references", { + qfmr <- pecotmr:::.withRowLdRefs(.cp_makeQtlFmr(), .cp_ldm(0.2)) + gfmr <- pecotmr:::.withRowLdRefs(.cp_makeGwasFmr(), .cp_ldm(0.8)) + expect_error( + pecotmr:::.colocRequireMatchingLdRefs(qfmr, gfmr), + "disagree on the LD" + ) +}) + +test_that("coloc lets rows that never pair sit on different references", { + # The QTL row is on chr1 and the GWAS row on chr2, so coloc never scores + # them against each other and their references need not match. + qfmr <- pecotmr:::.withRowLdRefs(.cp_makeQtlFmr(), .cp_ldm(0.2)) + chr2 <- .cp_makeFmEntry(variant_ids = paste0("chr2:", 100 * (1:5), ":A:G")) + gfmr <- pecotmr:::.withRowLdRefs( + .cp_makeGwasFmr(entries = list(chr2)), + .cp_ldm(0.8, chrom = "chr2") + ) + expect_null(pecotmr:::.colocRequireMatchingLdRefs(qfmr, gfmr)) +}) + +# =========================================================================== +# A QTL region over several GWAS LD blocks is one colocalization +# =========================================================================== + +# One GWAS study fine-mapped in two LD blocks: chr1:100-500 in block +# chr1_1_550 and chr1:600-1000 in block chr1_551_2000, two effects each. +.cp_blockIds <- c("chr1_1_550", "chr1_551_2000") +.cp_blockWindows <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 551L), c(550L, 2000L)) +) + +.cp_makeBlockedGwasFmr <- function( + blockId = .cp_blockIds, + method = "susie", + region = .cp_blockWindows +) { + GwasFineMappingResult( + studyName = rep("G1", 2L), + method = rep(method, 2L), + entry = list( + .cp_makeFmEntry(paste0("chr1:", 100 * (1:5), ":A:G")), + .cp_makeFmEntry(paste0("chr1:", 100 * (6:10), ":A:G")) + ), + blockId = blockId, + region = region, + ldReference = .cp_makeHandle(snp_n = 10L) + ) +} + +# A QTL fit over `positions` (multiples of 100 on chr1). +.cp_makeQtlOver <- function(positions, trait = "t1") { + QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = trait, + method = "susie", + entry = list(.cp_makeFmEntry(paste0("chr1:", positions, ":A:G"))), + ldReference = .cp_makeHandle(snp_n = 10L) + ) +} + +test_that(".colocCollapseBlocks stacks blocks, each confined to its own", { + recs <- pecotmr:::.colocPreextractGwasLbf( + .cp_makeBlockedGwasFmr(), + ColocLbfFilterParam() + ) + expect_length(recs, 2L) + one <- pecotmr:::.colocCollapseBlocks(recs[1L]) + expect_identical(one, recs[[1L]]) + merged <- pecotmr:::.colocCollapseBlocks(recs) + blockA <- paste0("chr1:", 100 * (1:5), ":A:G") + blockB <- paste0("chr1:", 100 * (6:10), ":A:G") + expect_identical(colnames(merged$lbf), c(blockA, blockB)) + # Block A's effects carry no evidence about block B's variants, and the + # reverse. + expect_true(all(merged$lbf[1:2, blockB] == -Inf)) + expect_true(all(merged$lbf[3:4, blockA] == -Inf)) + expect_equal(merged$lbf[1:2, blockA], recs[[1L]]$lbf) + # Block B's effects are numbered on from block A's two. + expect_identical(merged$effect, 1:4) + expect_identical(merged$nEffects, 4L) + # The blockIds spell coordinates, so the merged block is their union. + expect_identical(merged$blockId, "chr1_1_2000") + expect_match(merged$label, "chr1_1_2000") +}) + +test_that(".colocMergedBlockId names the stretch a fit's blocks cover", { + blocks <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 551L), c(550L, 2000L)) + ) + spans <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 600L), c(500L, 1000L)) + ) + # The stretch comes from the blocks' windows, whatever the ids say. + expect_identical( + pecotmr:::.colocMergedBlockId(.cp_blockIds, blocks), + "chr1_1_2000" + ) + expect_identical( + pecotmr:::.colocMergedBlockId(c("blockA", "blockB"), spans), + "chr1_100_1000" + ) + # One block keeps its own id, whatever it is. + expect_identical( + pecotmr:::.colocMergedBlockId("blockA", blocks[1L]), + "blockA" + ) + expect_identical(pecotmr:::.colocMergedBlockId("chr1", spans[1L]), "chr1") +}) + +test_that(".colocMergedLdRef keeps a shared reference and drops a split one", { + ref <- .cp_makeHandle() + same <- list( + list(ldKey = "ld1", ldReference = ref), + list(ldKey = "ld1", ldReference = ref) + ) + expect_identical(pecotmr:::.colocMergedLdRef(same), ref) + split <- list( + list(ldKey = "ld1", ldReference = ref), + list(ldKey = "ld2", ldReference = ref) + ) + expect_null(pecotmr:::.colocMergedLdRef(split)) +}) + +test_that("colocPipeline scores a region over two blocks as one fit", { + skip_if_not_installed("coloc") + set.seed(3) + res <- suppressWarnings(colocPipeline( + .cp_makeQtlOver(100 * (1:10)), + gwasInput = .cp_makeBlockedGwasFmr(), + adjustPips = FALSE + )) + pairs <- colocPairs(res) + expect_identical(unique(pairs$blockId), "chr1_1_2000") + # Every QTL effect is scored over its whole region, against all four GWAS + # effects of the one collapsed fit. + expect_true(all(pairs$nSnps == 10L)) + expect_setequal(pairs$gwasCs, 1:4) + pp <- as.matrix(pairs[, str_c("PP.H", 0:4, ".abf")]) + expect_false(anyNA(pp)) + expect_equal(unname(rowSums(pp)), rep(1, nrow(pairs))) + # A region inside one block reads that block alone, under its own id. + inside <- suppressWarnings(colocPipeline( + .cp_makeQtlOver(100 * (1:5)), + gwasInput = .cp_makeBlockedGwasFmr(), + adjustPips = FALSE + )) + expect_identical(unique(colocPairs(inside)$blockId), "chr1_1_550") + expect_true(all(colocPairs(inside)$nSnps == 5L)) +}) + +test_that("colocPipeline keeps two methods' block fits apart", { + skip_if_not_installed("coloc") + set.seed(4) + gfmr <- combineFineMappingResults( + .cp_makeBlockedGwasFmr(method = "susie"), + .cp_makeBlockedGwasFmr(method = "ser") + ) + res <- suppressWarnings(colocPipeline( + .cp_makeQtlOver(100 * (1:10)), + gwasInput = gfmr, + adjustPips = FALSE + )) + pairs <- colocPairs(res) + byMethod <- split(pairs$gwasCs, pairs$gwasMethod) + expect_setequal(names(byMethod), c("susie", "ser")) + expect_setequal(byMethod$susie, 1:4) + expect_setequal(byMethod$ser, 1:4) +}) + +# A GwasSumStats split into the two blocks above, and a fineMappingPipeline +# stand-in that records what it was given and fits each row it was handed. +.cp_makeBlockedGwasSumstats <- function() { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:10), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:10)), + A1 = "A", + A2 = "G", + Z = seq_len(10L) / 10, + N = 1000L + ) + GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + ldReference = .cp_makeHandle(snp_n = 10L), + qcOptions = list(step1 = "ok"), + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 551L), c(550L, 2000L)) + ) + ) +} + +.cp_recordingFineMapper <- function(seen) { + function(data, methods, ...) { + seen$data <- data + GwasFineMappingResult( + studyName = as.character(data$study), + method = rep("susie", nrow(data)), + entry = map( + as.list(data), + function(gr) .cp_makeFmEntry(S4Vectors::mcols(gr)$SNP) + ), + blockId = as.character(data$blockId), + ldReference = .cp_makeHandle(snp_n = 10L) + ) + } +} + +test_that("colocPipeline fine-maps each set of blocks a region reaches once", { + seen <- new.env() + scored <- new.env() + scored$gwas <- character(0) + local_mocked_bindings( + fineMappingPipeline = .cp_recordingFineMapper(seen), + .package = "pecotmr" + ) + local_mocked_bindings( + coloc.bf_bf = function(qLbf, gLbf, p1, p2, p12, ...) { + scored$gwas <- c(scored$gwas, str_flatten(colnames(gLbf), ",")) + .cp_mockColocBfBf()(qLbf, gLbf, p1, p2, p12) + }, + .package = "coloc" + ) + # The first region reaches no GWAS row, so the PIP reconciliation drops + # it, and the regions after it move up a row; each must still find its + # own fit. + elsewhere <- QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = "elsewhere", + method = "susie", + entry = list(.cp_makeFmEntry(paste0("chr2:", 100 * (1:5), ":A:G"))) + ) + qtl <- combineFineMappingResults( + elsewhere, + .cp_makeQtlOver(100 * (1:5), trait = "inside"), + .cp_makeQtlOver(100 * (4:8), trait = "across") + ) + res <- suppressMessages(suppressWarnings(colocPipeline( + qtl, + gwasInput = .cp_makeBlockedGwasSumstats(), + returnGwasFineMapping = TRUE + ))) + # Two sets: block A alone, and both blocks stitched together. + expect_identical( + as.character(seen$data$blockId), + c("chr1_1_550", "chr1_1_2000") + ) + expect_identical(unname(lengths(seen$data)), c(5L, 10L)) + # Each set's range is the stretch its blocks' given ranges cover. + expect_identical( + as.character(seen$data$region), + c("chr1:1-550", "chr1:1-2000") + ) + expect_identical(seen$data$regionGiven, c(TRUE, TRUE)) + # Each region is scored against its own set's fit and no other. + pairs <- colocPairs(res) + expect_identical( + pairs$blockId[match(c("inside", "across"), pairs$trait)], + c("chr1_1_550", "chr1_1_2000") + ) + expect_length(scored$gwas, 2L) + expect_identical( + S4Vectors::mcols(attr(res, "gwasFineMapping"))$blockId, + c("chr1_1_550", "chr1_1_2000") + ) +}) + +test_that("colocPipeline needs one LD reference across stitched blocks", { + gws <- pecotmr:::.withRowLdRefs( + .cp_makeBlockedGwasSumstats(), + list(.cp_ldm(0.2), .cp_ldm(0.5)) + ) + expect_error( + pecotmr:::.colocResolveGwasFmr( + gws, + GwasFineMappingParam(), + .cp_makeQtlOver(100 * (4:8)) + ), + "the rows of GWAS study 'G1' a QTL region reaches use 2" + ) +}) + +test_that("colocPipeline fine-maps nothing when no region reaches the GWAS", { + resolved <- pecotmr:::.colocResolveGwasFmr( + .cp_makeBlockedGwasSumstats(), + GwasFineMappingParam(), + QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(.cp_makeFmEntry(paste0("chr2:", 100 * (1:5), ":A:G"))) + ) + ) + expect_equal(nrow(resolved$fmr), 0L) + expect_equal(nrow(resolved$pairing), 0L) +}) + +test_that(".colocWithNull adds coloc's null column at log BF 0", { + m <- matrix(c(1, -Inf), 1L, dimnames = list(NULL, c("a", "b"))) + expect_identical( + pecotmr:::.colocWithNull(m), + cbind(m, null = 0) + ) +}) + +test_that("enloc reads SuSiE's natural-log Bayes factors as such", { + # With a flat GWAS effect the colocalization mass follows the QTL PIPs, + # which must be SuSiE's softmax over natural-log Bayes factors. + lbf <- c(2, 1, 0) + aligned <- list( + qtl = matrix(lbf, 1L, dimnames = list(NULL, c("a", "b", "c"))), + gwas = matrix(0, 1L, 3L, dimnames = list(NULL, c("a", "b", "c"))) + ) + out <- pecotmr:::.colocEnlocOneEffectPair( + 1L, + 1L, + aligned, + list(p1 = 1e-4, p2 = 1e-4, p12 = 5e-6) + ) + expect_equal( + unname(out$scp / sum(out$scp)), + exp(lbf) / sum(exp(lbf)) + ) +}) + +test_that("the enrichment lookup matches on method when the table has it", { + enr <- data.frame( + gwasStudy = "G1", + gwasMethod = c("susie", "ser"), + qtlStudy = "Q1", + qtlContext = "c1", + qtlMethod = "susie", + enrichment = c(1, 2) + ) + expect_null(pecotmr:::.colocValidateEnrichmentKeys(enr)) + q <- list(study = "Q1", context = "c1", trait = "t1", method = "susie") + gwas <- function(m) { + list(study = "G1", context = NA, trait = NA, method = m) + } + expect_identical( + pecotmr:::.colocLookupEnrichment(enr, gwas("ser"), q), + 2L + ) + expect_identical( + pecotmr:::.colocLookupEnrichment(enr, gwas("susie"), q), + 1L + ) + expect_true(is.na( + pecotmr:::.colocLookupEnrichment(enr, gwas("susieInf"), q) + )) +}) + +test_that("a stitched set of blocks keeps its case and control counts", { + gws <- .cp_makeBlockedGwasSumstats() + withCounts <- GwasSumStats( + studyName = "G1", + entry = list(sumStats(gws)), + genome = "hg19", + ldReference = .cp_makeHandle(snp_n = 10L), + nCase = 100, + nControl = 200, + qcOptions = list(step1 = "ok"), + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 551L), c(550L, 2000L)) + ) + ) + sets <- pecotmr:::.colocQtlRowSets( + withCounts, + .cp_makeQtlOver(100 * (4:8)) + ) + u <- pecotmr:::.colocUnionSumStats(withCounts, sets) + expect_equal(nrow(u), 1L) + expect_equal(u$nCase, 100) + expect_equal(u$nControl, 200) + expect_false("nSample" %in% colnames(S4Vectors::mcols(u))) +}) + +test_that("a stitched set is given its range only when every block was", { + gws <- .cp_makeBlockedGwasSumstats() + sets <- pecotmr:::.colocQtlRowSets(gws, .cp_makeQtlOver(100 * (4:8))) + given <- pecotmr:::.colocUnionSumStats(gws, sets) + expect_identical(as.character(given$region), "chr1:1-2000") + expect_true(given$regionGiven) + # The same blocks with their ranges computed: the set's range is the + # stretch their spans cover, and it is computed too. + computed <- GwasSumStats( + studyName = c("G1", "G1"), + entry = as.list(gws), + genome = "hg19", + ldReference = .cp_makeHandle(snp_n = 10L), + qcOptions = list(step1 = "ok"), + blockId = c("bA", "bB") + ) + u <- pecotmr:::.colocUnionSumStats( + computed, + pecotmr:::.colocQtlRowSets(computed, .cp_makeQtlOver(100 * (4:8))) + ) + expect_identical(u$blockId, "chr1_100_1000") + expect_identical(as.character(u$region), "chr1:100-1000") + expect_false(u$regionGiven) +}) + +# =========================================================================== +# A region reaching past the GWAS blocks that were loaded +# =========================================================================== + +test_that("colocPipeline refuses a region reaching past given blocks", { + skip_if_not_installed("coloc") + # The blocks' ids spell their ranges, so chr1:2100 lies in a block that + # was not loaded. + expect_error( + colocPipeline( + .cp_makeQtlOver(c(100 * (1:10), 2100)), + gwasInput = .cp_makeBlockedGwasFmr(), + adjustPips = FALSE + ), + "1 variant(s) past the end of block chr1:551-2000 of GWAS study", + fixed = TRUE + ) + # Statistics are checked before any block is fine-mapped. + expect_error( + colocPipeline( + .cp_makeQtlOver(c(100 * (4:8), 2100)), + gwasInput = .cp_makeBlockedGwasSumstats() + ), + "lie in blocks that were not loaded" + ) +}) + +test_that("colocPipeline warns of a region running past computed blocks", { + # Labels rather than coordinates: the blocks' ranges are the spans of + # their variants, chr1:100-500 and chr1:600-1000. + gfmr <- .cp_makeBlockedGwasFmr(blockId = c("bA", "bB"), region = NULL) + expect_warning( + pecotmr:::.colocCheckBlockReach(.cp_makeQtlOver(100 * (1:12)), gfmr), + "2 variant\\(s\\) past the end of block bB \\(chr1:600-1000\\)" + ) + # One variant past a computed range may only be one the GWAS lacks. + expect_no_warning( + pecotmr:::.colocCheckBlockReach(.cp_makeQtlOver(100 * (1:11)), gfmr) + ) + # A region meeting no block of the study is not checked against it. + expect_no_warning( + pecotmr:::.colocCheckBlockReach(.cp_makeQtlOver(100 * (30:35)), gfmr) + ) + # Nor is a second side that has no blocks. + expect_null( + pecotmr:::.colocCheckBlockReach( + .cp_makeQtlOver(100 * (1:12)), + .cp_makeQtlOver(100 * (1:5)) + ) + ) +}) + +# =========================================================================== +# LBF column names come from the fit's own variants +# =========================================================================== + +test_that("an unnamed LBF matrix is named by the variants of its fit", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) + res <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "g1", + method = "susie", + entry = list(FineMappingRow(vids, list(pip = tl$pip), tl)) + ) + # The row holds two of the three variants the fit's columns are. + parts <- pecotmr:::.fmrRowParts(endoapply(res, utils::head, 2L), 1L) + named <- pecotmr:::.colocLbfNamesFrom(matrix(c(1, 2, 3), 1L), parts) + expect_equal(colnames(named), vids) + # A matrix that names its own columns keeps them; one matching no + # variant list stays unnamed. + own <- matrix(1:3, 1L, dimnames = list(NULL, c("a", "b", "c"))) + expect_identical(pecotmr:::.colocLbfNamesFrom(own, parts), own) + expect_null( + colnames(pecotmr:::.colocLbfNamesFrom(matrix(1:2, 1L), parts)) + ) +}) + +# =========================================================================== +# Narrowed rows: a fit scored whole warns +# =========================================================================== + +test_that("fits scored as supplied warn about narrowed rows on both sides", { + data(qtlFineMappingExample, gwasFineMappingExample) + qtl <- endoapply(qtlFineMappingExample, utils::head, 2000L) + gwas <- endoapply(gwasFineMappingExample, utils::head, 2000L) + cnd <- tryCatch( + pecotmr:::.colocMaybeAdjustPips( + adjustPips = FALSE, + qtlFineMappingResult = qtl, + gwasFmr = gwas + ), + warning = identity + ) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_match(conditionMessage(cnd), "colocPipeline\\(\\): 2 row\\(s\\)") + # An empty side scores nothing, so nothing is read. + expect_no_warning(pecotmr:::.colocMaybeAdjustPips( + adjustPips = FALSE, + qtlFineMappingResult = qtl[0], + gwasFmr = gwas + )) +}) + +test_that("colocPipeline warns about narrowed fits only when not adjusting", { + skip_if_not_installed("coloc") + data(qtlFineMappingLbfExample, gwasFineMappingLbfExample) + narrowed <- endoapply(qtlFineMappingLbfExample, utils::head, 150L) + asSupplied <- .fitCoverageMessages(colocPipeline( + narrowed, + gwasInput = gwasFineMappingLbfExample, + adjustPips = FALSE + )) + expect_length(asSupplied, 1L) + expect_match(asSupplied, "colocPipeline\\(\\): 2 row\\(s\\)") + # The adjustment restricts each fit to the variants its row keeps. + expect_length( + .fitCoverageMessages(colocPipeline( + narrowed, + gwasInput = gwasFineMappingLbfExample + )), + 0L + ) +}) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index 83b93049..7a827b3b 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -1,77 +1,5 @@ context("colocboostPipeline") -# ============================================================================ -# Legacy colocboostPipeline tests removed for the post-S4-refactor API. -# ============================================================================ -# -# This file previously contained ~100 test_that blocks targeting the legacy -# colocboost pipeline API (rssData/ldData list-shape inputs, RegionalData -# fixtures, qcRegionalData driver, colocboostAnalysis adapters, etc.). Every -# block exercised functions and classes that no longer exist in pecotmr: -# -# Functions removed: -# - colocboostAnalysis() (direct colocboost adapter) -# - qcRegionalData() (legacy QC driver) -# - regionDataToIndInput() (now a .Deprecated() no-op) -# - regionDataToRssInput() (now a .Deprecated() no-op) -# - regionDataToColocboostInput() -# - rssAnalysisPipeline() (replaced by fineMappingPipeline) -# - rssBasicQc() (folded into summaryStatsQc) -# - loadRssData() (replaced by SumStats constructors) -# - getrssinput(), getlddata(), getoutliernumber() -# - colocWrapper(), xqtlEnrichmentWrapper(), colocPostProcessor() -# (now .Deprecated() no-ops returning NULL) -# - .runColocboost() (replaced by internal .cbRun(label, args)) -# - buildLdArgs() (replaced by internal .cbBuildLdArgs()) -# -# Classes removed: -# - RegionalData, MultivariateRegionalData -# - QcResult, AlleleQcResult -# -# The replacement API has a fundamentally different contract: -# -# colocboostPipeline() is now an S4 generic dispatching on the QTL input -# class. Signatures live in R/colocboostPipeline.R: -# -# setMethod("colocboostPipeline", "QtlDataset", ...) -# setMethod("colocboostPipeline", "QtlSumStats", ...) -# setMethod("colocboostPipeline", "MultiStudyQtlDataset", ...) -# -# - QTL data is supplied as a QtlDataset / QtlSumStats / MultiStudyQtlDataset -# (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(...) -# argument. -# - Individual-level QC (MAF / X-variance / sample missingness / event -# selection) lives on the QtlDataset constructor and is applied lazily -# by its accessors. There is no separate qcRegionalData() pass. -# - All summary-statistic QC lives in summaryStatsQc(). The pipeline -# rejects QtlSumStats / GwasSumStats whose qcInfo() is empty. -# -# Rewriting the legacy tests in place would require fabricating new -# QtlDataset / QtlSumStats / GwasSumStats / MultiStudyQtlDataset fixtures -# and asserting against a different result shape -- i.e. inventing new -# coverage rather than porting existing coverage. That is out of scope -# for this legacy-cleanup pass. -# -# New tests for the S4 colocboostPipeline() methods, summaryStatsQc(), and -# the QtlDataset / QtlSumStats / GwasSumStats / MultiStudyQtlDataset -# constructors should be added in dedicated files alongside this one -# (e.g. test_colocboost_pipeline_qtl_dataset.R, -# test_colocboost_pipeline_qtl_sumstats.R, -# test_colocboost_pipeline_multitask.R). See: -# -# - R/colocboostPipeline.R (the new S4 generic + methods) -# - R/allClasses.R (QtlDataset, QtlSumStats, GwasSumStats, -# MultiStudyQtlDataset, FineMappingRow) -# - R/allMethods.R (constructors) -# - R/sumstatsQc.R (summaryStatsQc, which is now the only -# summary-statistic QC entry point) -# - tests/testthat/test_sumstatsQc.R (existing QC coverage) -# ============================================================================ - -# Sentinel test so the testthat context is non-empty. test_that("colocboostPipeline is exported as an S4 generic", { expect_true("colocboostPipeline" %in% getNamespaceExports("pecotmr")) expect_true(methods::isGeneric("colocboostPipeline")) @@ -85,29 +13,10 @@ 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, -# .cbRequireMatchingLdRefs, .cbEmptyResult) are exercised directly. +# (.cbBuildLdArgs, .cbMergeSumstatBundles, .cbResultLdRefs, .cbEmptyResult) +# are exercised directly. # =========================================================================== -.cbp_makeHandle <- function(snp_n = 6L, n_samples = 30L, sample_prefix = "s") { - new( - "GenotypeHandle", - path = "/tmp/cb", - format = "plink2", - 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(sample_prefix, seq_len(n_samples)), - pgenPtr = NULL - ) -} - .cbp_mockExtractor <- function(seed = 11, n_samples = 30L) { function(handle, snpIdx, meanImpute = TRUE) { set.seed(seed) @@ -212,11 +121,11 @@ context("colocboostPipeline (S4 dispatch)") entry = list(gr), genome = "hg19", ldReference = .cbp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } -.cbp_makeGwasSumStats <- function(qc = TRUE) { +.cbp_makeGwasSumStats <- function(qc = TRUE, ldReference = .cbp_makeHandle()) { gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges( @@ -235,11 +144,19 @@ context("colocboostPipeline (S4 dispatch)") studyName = "G1", entry = list(gr), genome = "hg19", - ldReference = .cbp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + ldReference = ldReference, + qcOptions = if (qc) list(step1 = "ok") else list() ) } +# An LdMatrix over the fixtures' five variants, so a side can be put on a +# reference other than the shared genotype panel. +.cbp_makeLdMatrix <- function(rho = 0.2) { + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) + r <- rho^abs(outer(1:5, 1:5, "-")) + LdMatrix(`dimnames<-`(r, list(ids, ids))) +} + # =========================================================================== # Internal helpers (run-anywhere) # =========================================================================== @@ -265,44 +182,21 @@ test_that(".cbBuildLdArgs: empty list returns empty list", { expect_equal(pecotmr:::.cbBuildLdArgs(list()), list()) }) -test_that("SignalScreenParam enforces one metric and threads the right spec", { - expect_error( - SignalScreenParam(pip = 0.5, absZ = 5), - "only one screening metric" - ) - expect_equal( - pecotmr:::.screenResolve(SignalScreenParam(absZ = 5)), - list(metric = "absZ", cutoff = 5) - ) - expect_equal( - pecotmr:::.screenResolve(SignalScreenParam(bf = 100)), - list(metric = "bf", cutoff = 100) +test_that(".cbResidualizedY skips a context whose residualization fails", { + # A failing context is skipped with a message naming it, so one bad + # context does not end the whole run. + local_mocked_bindings( + .qtlResidualizedPhenotypes = function(...) { + stop("no samples shared") + }, + .package = "pecotmr" ) - # legacy pip scalar passes through as a bare numeric - expect_equal(pecotmr:::.screenResolve(SignalScreenParam(pip = 0.3)), 0.3) - expect_equal( - pecotmr:::.screenResolve(SignalScreenParam(pip = c(brain = 0.3))), - c(brain = 0.3) - ) # context-named pass-through - expect_null(pecotmr:::.screenResolve(SignalScreenParam())) -}) - -test_that(".cbResolveCutoff passes a screen object through uniformly", { - sc <- list(metric = "absZ", cutoff = 5) - expect_identical(pecotmr:::.cbResolveCutoff(sc, "brain"), sc) - expect_identical(pecotmr:::.cbResolveCutoff(sc, "blood"), sc) - expect_equal(pecotmr:::.cbResolveCutoff(c(brain = 0.3), "brain"), 0.3) - expect_equal(pecotmr:::.cbResolveCutoff(c(brain = 0.3), "blood"), 0) # unlisted ctx - expect_equal(pecotmr:::.cbResolveCutoff(0.5, "any"), 0.5) -}) - -test_that("enabling two screen metrics errors where it is written", { - # The constructor enforces it, so this fails at the call that builds the - # bundle -- before any pipeline runs. - expect_error( - SignalScreenParam(pip = 0.5, bf = 100), - "only one screening metric" + expect_message( + out <- pecotmr:::.cbResidualizedY(NULL, "brain", NULL, NULL), + "skipping context 'brain' (residualized phenotypes unavailable)", + fixed = TRUE ) + expect_null(out) }) test_that(".cbRequireSumStatsQc: un-QCd input errors", { @@ -323,39 +217,6 @@ test_that(".cbRequireSumStatsQc: QCd input passes", { }) -test_that(".cbRequireMatchingLdRefs: NULL sides are allowed", { - expect_silent(pecotmr:::.cbRequireMatchingLdRefs( - NULL, - .cbp_makeHandle() - )) - expect_silent(pecotmr:::.cbRequireMatchingLdRefs( - .cbp_makeHandle(), - NULL - )) -}) - -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:::.cbRequireMatchingLdRefs( - .cbp_makeHandle(snp_n = 4L), - .cbp_makeHandle(snp_n = 5L) - )), - "share 4 variant" - ) -}) - -test_that(".cbRequireMatchingLdRefs: sample-set mismatch errors", { - expect_error( - pecotmr:::.cbRequireMatchingLdRefs( - .cbp_makeHandle(sample_prefix = "a"), - .cbp_makeHandle(sample_prefix = "b") - ), - "different sample sets" - ) -}) - test_that(".cbMergeSumstatBundles: empty input gives empty dict", { res <- pecotmr:::.cbMergeSumstatBundles(list()) expect_equal(length(res$sumstat), 0L) @@ -375,8 +236,9 @@ test_that(".cbMergeSumstatBundles: identical LD matrices are deduplicated", { expect_identical(res$ldArg, "LD") }) -test_that(".cbMergeSumstatBundles records factors and refuses a mix", { - f <- matrix(c(1, -1, 0.5, -0.5), 2) +test_that(".cbMergeSumstatBundles records factors and turns a mix into LD", { + ids <- c("v1", "v2") + f <- matrix(c(1, -1, 0.5, -0.5), 2, dimnames = list(NULL, ids)) 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) @@ -384,11 +246,18 @@ test_that(".cbMergeSumstatBundles records factors and refuses a mix", { 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" - ) + # colocboost takes LD or X_ref, never both, so a run whose two sides use + # different kinds of reference gets the factor as its LD matrix. + ld <- matrix(c(1, 0.3, 0.3, 1), 2, dimnames = list(ids, ids)) + mixed <- list_assign( + factors, + b = list(sumstat = data.frame(z = 3:4), LD = ld, isFactor = FALSE) + ) + res <- pecotmr:::.cbMergeSumstatBundles(mixed) + expect_identical(res$ldArg, "LD") + expect_equal(res$LD[[1L]], crossprod(f) / (nrow(f) - 1L)) + expect_identical(res$LD[[2L]], ld) + expect_equal(unname(res$dict_sumstatLD[, "LD"]), 1:2) }) test_that(".cbEmptyResult: is the internal per-analysis accumulator", { @@ -433,7 +302,7 @@ test_that("colocboostPipeline(QtlDataset): runs xqtl-only ColocBoost with mocked # ran" is read off the recorded timing rather than off a retained raw # object -- the timing is written whether or not the run produced sets. expect_s4_class(out, "ColocBoostResult") - expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) + expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) expect_true("X" %in% names(capturedArgs)) }) @@ -443,17 +312,35 @@ test_that("colocboostPipeline(QtlDataset): no QTL bundle and no GWAS returns emp extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) - # An impossible traitId narrows the phenotype matrix to zero columns; - # the bundle ends up NULL and the driver short-circuits. + # A signal screen no outcome clears skips every context; the bundle + # ends up NULL and the driver short-circuits. out <- suppressMessages(suppressWarnings( colocboostPipeline( qd, contexts = "brain", - traitId = "ENSG_DOES_NOT_EXIST", + signalScreenParam = SignalScreenParam(absZ = 1e6), xqtlColoc = TRUE ) )) - expect_null(out$xqtl_coloc) + # No confidence set, and no analysis ran to be timed. + expect_s4_class(out, "ColocBoostResult") + expect_length(out, 0L) + expect_equal(nrow(computingTime(out)), 0L) +}) + +test_that("colocboostPipeline refuses a trait selection that matches nothing", { + # As fineMappingPipeline and twasWeightsPipeline do, rather than + # returning an empty result. + expect_error( + colocboostPipeline(.cbp_makeQtlDataset(), traitId = "nope"), + "colocboostPipeline(QtlDataset): no traits selected.", + fixed = TRUE + ) + expect_error( + colocboostPipeline(.cbp_makeQtlSumStats(), traitId = "nope"), + "colocboostPipeline(QtlSumStats): no entries matched the ", + fixed = TRUE + ) }) # =========================================================================== @@ -508,7 +395,7 @@ test_that("colocboostPipeline: jointGwas merges qtl + gwas sumstats and runs onc separateGwas = FALSE ) ) - expect_true(is_in("joint_gwas", names(computingTime(out)$Analysis))) + expect_true(is_in("joint_gwas", computingTime(out)$analysis)) }) test_that("colocboostPipeline: separateGwas runs once per GWAS study", { @@ -549,7 +436,7 @@ test_that("colocboostPipeline: separateGwas runs once per GWAS study", { # The QTL side's LD travels with it, so the dict covers both sumstats. expect_equal(nrow(call$dict_sumstatLD), 2L) expect_true( - is_in("separate_gwas", names(computingTime(out)$Analysis)) + is_in("separate_gwas", computingTime(out)$analysis) ) }) @@ -610,87 +497,117 @@ test_that("colocboostPipeline: no analysis flag set is an error", { } }) -test_that("colocboostPipeline: GWAS ldReference mismatch errors in driver", { +test_that("a GWAS on a different LD reference runs, and both are recorded", { + # The two sides need not share a reference: a GWAS panel with another + # sample set is matched against on its own rather than refused. ss <- .cbp_makeQtlSumStats() - # Build a GwasSumStats whose ldReference has a different sample set. - gh_diff <- .cbp_makeHandle(sample_prefix = "z") - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = 5L), - width = 1L - ) + gs <- .cbp_makeGwasSumStats( + ldReference = .cbp_makeHandle(sample_prefix = "z") ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), - A1 = rep("A", 5), - A2 = rep("G", 5), - Z = rnorm(5), - N = rep(1000L, 5) - ) - gs <- GwasSumStats( - studyName = "G1", - entry = list(gr), - genome = "hg19", - ldReference = gh_diff, - qcInfo = list(step1 = "ok") - ) - # .cbQtlSumStatsBundle reads the qtl sketch via extractBlockGenotypes - # before the LD-sketch mismatch check fires further down the driver, so - # mock the extractor here too. + seen <- list() local_mocked_bindings( extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) - expect_error( - suppressMessages( - colocboostPipeline( - ss, - gwasSumStats = gs, - xqtlColoc = FALSE, - jointGwas = TRUE - ) - ), - "different sample sets" + local_mocked_bindings( + colocboost = function(...) { + seen[[length(seen) + 1L]] <<- list(...) + list(jointly_run = TRUE) + }, + .package = "colocboost" ) + out <- suppressMessages( + colocboostPipeline( + ss, + gwasSumStats = gs, + xqtlColoc = FALSE, + jointGwas = TRUE + ) + ) + expect_equal(length(seen), 1L) + expect_equal(nrow(seen[[1L]]$dict_sumstatLD), 2L) + # Each outcome keys to the reference it was matched against. + refs <- ldReference(out) + expect_length(refs, 2L) + info <- out@outcomeInfo + keys <- info$ldReference[match(c("Q1:c1:t1", "G1"), info$name)] + expect_identical(refs[[keys[[1L]]]], ldReference(ss)[[1L]]) + expect_identical(refs[[keys[[2L]]]], ldReference(gs)[[1L]]) }) -# =========================================================================== -# GWAS case/control: optional nCase/nControl columns + effective-N wiring -# =========================================================================== - -test_that("GwasSumStats: nCase/nControl are optional columns (absent by default)", { - gr <- GenomicRanges::GRanges( - seqnames = "chr1", - ranges = IRanges::IRanges( - start = seq(100L, by = 100L, length.out = 5L), - width = 1L +test_that("a panel and an LdMatrix on opposite sides reach colocboost as LD", { + ss <- .cbp_makeQtlSumStats() + ldm <- .cbp_makeLdMatrix() + gs <- .cbp_makeGwasSumStats(ldReference = ldm) + seen <- list() + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + local_mocked_bindings( + colocboost = function(...) { + seen[[length(seen) + 1L]] <<- list(...) + list(jointly_run = TRUE) + }, + .package = "colocboost" + ) + out <- suppressMessages( + colocboostPipeline( + ss, + gwasSumStats = gs, + xqtlColoc = TRUE, + jointGwas = TRUE ) ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), - A1 = "A", - A2 = "G", - Z = rnorm(5), - N = rep(1000L, 5) + nSumstats <- map_int(seen, function(call) length(call$sumstat)) + xqtl <- seen[[which(nSumstats == 1L)]] + joint <- seen[[which(nSumstats == 2L)]] + # The QTL-only run has one kind of reference and keeps the panel's factor. + expect_null(xqtl$LD) + factor <- xqtl$X_ref[[1L]] + # colocboost takes LD or X_ref but not both, so the joint run gets the + # panel's factor as its LD matrix alongside the LdMatrix's own. + expect_null(joint$X_ref) + dict <- joint$dict_sumstatLD + expect_equal( + joint$LD[[dict[1L, "LD"]]], + crossprod(factor) / (nrow(factor) - 1L) ) - base <- list( - study = "G1", - entry = list(gr), - genome = "hg19", - ldReference = .cbp_makeHandle(), - qcInfo = list(ok = 1) + expect_equal( + unname(joint$LD[[dict[2L, "LD"]]]), + 0.2^abs(outer(1:5, 1:5, "-")) + ) + expect_identical( + unname(ldReference(out)), + list(ldReference(ss)[[1L]], ldm) ) - g0 <- exec(GwasSumStats, !!!base) - expect_false(any( - c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g0)) - )) - g1 <- exec(GwasSumStats, !!!c(base, list(nCase = 500, nControl = 1500))) - expect_true(all(c("nCase", "nControl") %in% colnames(S4Vectors::mcols(g1)))) - expect_equal(g1$nCase, 500) - expect_equal(g1$nControl, 1500) }) +test_that(".cbResultLdRefs keys each outcome to its pair's reference", { + panel <- ldReference(.cbp_makeQtlSumStats())[[1L]] + ldm <- .cbp_makeLdMatrix() + pairs <- list( + `Q1:c1:t1` = list(ldReference = panel), + `Q1:c2:t1` = list(ldReference = panel), + G1 = list(ldReference = ldm) + ) + out <- pecotmr:::.cbResultLdRefs(pairs) + # Each distinct reference once, however many outcomes used it. + expect_identical(out$refs, list(ld1 = panel, ld2 = ldm)) + expect_equal( + out$keys, + c(`Q1:c1:t1` = "ld1", `Q1:c2:t1` = "ld1", G1 = "ld2") + ) + # No pairs, no references. + none <- pecotmr:::.cbResultLdRefs(list()) + expect_identical(none$refs, list()) + expect_length(none$keys, 0L) +}) + +# =========================================================================== +# GWAS case/control: optional nCase/nControl columns + effective-N wiring +# =========================================================================== + test_that("colocboost GWAS bundle: effective N for case/control, per-variant N otherwise", { gr <- GenomicRanges::GRanges( seqnames = "chr1", @@ -711,7 +628,7 @@ test_that("colocboost GWAS bundle: effective N for case/control, per-variant N o entry = list(gr), genome = "hg19", ldReference = .cbp_makeHandle(), - qcInfo = list(ok = 1) + qcOptions = list(ok = 1) ) local_mocked_bindings( extractBlockGenotypes = .cbp_mockExtractor(), @@ -758,7 +675,11 @@ test_that(".cbPipSkipOutcomes: keeps signal outcomes, drops noise, honours cutof expect_null(pecotmr:::.cbPipSkipOutcomes(X, Yn, 0.5)) }) -test_that(".cbResolveCutoff: scalar applies to all; named vector is per-context", { +test_that(".cbResolveCutoff: screen/scalar uniform, named vector per context", { + # A resolved screen object applies to every context alike. + sc <- list(metric = "absZ", cutoff = 5) + expect_identical(pecotmr:::.cbResolveCutoff(sc, "brain"), sc) + expect_identical(pecotmr:::.cbResolveCutoff(sc, "blood"), sc) expect_equal(pecotmr:::.cbResolveCutoff(0.5, "brain"), 0.5) expect_equal( pecotmr:::.cbResolveCutoff(c(brain = 0.3, blood = 0.7), "blood"), @@ -782,6 +703,47 @@ test_that(".cbResolveCutoff: scalar applies to all; named vector is per-context" ) } +test_that("colocboostPipeline(MultiStudy) refuses a trait no study carries", { + expect_error( + colocboostPipeline(.cbp_makeMultiStudy(), traitId = "nope"), + "colocboostPipeline(MultiStudyQtlDataset): no traits selected.", + fixed = TRUE + ) + # A trait only the embedded sumstats carry still selects something. + expect_silent(pecotmr:::.cbMsAssertTraitsSelected( + .cbp_makeMultiStudy(), + NULL, + "t1" + )) +}) + +test_that("colocboostPipeline(MultiStudy): context selection skips a study", { + # As in fineMappingPipeline: a context only some studies have is skipped + # for the others, with a warning, and one no study has is refused. + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + local_mocked_bindings( + colocboost = function(...) list(stub = TRUE), + .package = "colocboost" + ) + expect_warning( + out <- suppressMessages(colocboostPipeline( + .cbp_makeMultiStudy(), + contexts = "c1", + xqtlColoc = TRUE + )), + "study 'study1' is missing requested context\\(s\\): c1" + ) + # Only the summary statistics' outcome reached colocboost. + expect_identical(out@outcomeInfo$name, "Q1:c1:t1") + expect_error( + colocboostPipeline(.cbp_makeMultiStudy(), contexts = "ghost"), + "no study has: ghost" + ) +}) + test_that("colocboostPipeline(MultiStudyQtlDataset): combines per-study bundles + embedded sumstats", { mt <- .cbp_makeMultiStudy() capturedArgs <- NULL @@ -803,7 +765,7 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): combines per-study bundles separateGwas = FALSE )) expect_s4_class(out, "ColocBoostResult") - expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) + expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) # The individual study's outcome is prefixed "study1:" in the combined bundle. expect_true(any(grepl("study1:", names(capturedArgs$Y)))) }) @@ -818,11 +780,16 @@ test_that(".cbRun: an engine failure is caught -> message + NULL", { colocboost = function(...) stop("engine boom"), .package = "colocboost" ) - out <- suppressMessages(colocboostPipeline(qd, xqtlColoc = TRUE)) - expect_null(out$xqtl_coloc) # .cbRun caught (123-124) + expect_message( + out <- colocboostPipeline(qd, xqtlColoc = TRUE), + "xQTL-only ColocBoost failed" + ) + # The run was attempted and timed, and contributes no confidence set. + expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) + expect_length(out, 0L) }) -test_that(".cbIndividualBundle: multi-context bundle names + prefixes outcomes", { +test_that(".cbIndividualBundle: multi-context outcomes get context prefixes", { qd <- .cbp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") capturedArgs <- NULL local_mocked_bindings( @@ -837,9 +804,21 @@ test_that(".cbIndividualBundle: multi-context bundle names + prefixes outcomes", .package = "colocboost" ) out <- suppressMessages(colocboostPipeline(qd, xqtlColoc = TRUE)) - expect_true(is_in("xqtl_coloc", names(computingTime(out)$Analysis))) - # Two contexts -> two context-prefixed outcomes (covers the xMatch + naming). - expect_gte(length(capturedArgs$Y), 2L) + expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) + # ENSG_A is in both contexts, so each outcome is prefixed with its context + # to tell the two apart, and colocboost is handed those names. + prefixed <- c("brain_ENSG_A", "liver_ENSG_A") + expect_identical(names(capturedArgs$Y), prefixed) + expect_identical(capturedArgs$outcome_names, prefixed) + # The contexts share genotypes and samples, so their X deduplicates to the + # first context's, and dict_YX maps both outcomes to it (the xMatch). + expect_identical(names(capturedArgs$X), "brain") + expect_identical(capturedArgs$dict_YX, cbind(Y = 1:2, X = c(1L, 1L))) + # Each prefixed name still resolves to the context and trait behind it. + info <- out@outcomeInfo + expect_identical(info$name, prefixed) + expect_identical(info$context, c("brain", "liver")) + expect_identical(info$trait, c("ENSG_A", "ENSG_A")) }) test_that("colocboostPipeline(QtlDataset): unknown context errors", { @@ -851,7 +830,7 @@ test_that("colocboostPipeline(QtlDataset): unknown context errors", { expect_error( colocboostPipeline(qd, contexts = "ghost", xqtlColoc = TRUE), "Unknown context" - ) # 209 + ) }) test_that("colocboostPipeline(QtlDataset): pipCutoffToSkip dropping every outcome -> empty", { @@ -867,7 +846,9 @@ test_that("colocboostPipeline(QtlDataset): pipCutoffToSkip dropping every outcom signalScreenParam = SignalScreenParam(pip = 0.9999) ) )) - expect_null(out$xqtl_coloc) # 249-253 skip -> empty + # The screen leaves no outcome, so nothing runs and no set is reported. + expect_length(out, 0L) + expect_equal(nrow(computingTime(out)), 0L) }) test_that(".cbPipSkipOutcomes: an outcome with < 2 observations is skipped", { @@ -880,11 +861,11 @@ test_that(".cbPipSkipOutcomes: an outcome with < 2 observations is skipped", { ) Y <- cbind(a = c(1, rep(NA, 29)), b = rnorm(30)) # col a: 1 obs (< 2) res <- pecotmr:::.cbPipSkipOutcomes(X, Y, 0.5) - expect_true(is.null(res) || is.matrix(res)) # col a -> next (180) + expect_false(is_in("a", colnames(res))) }) test_that(".cbSumstatPair: NULL / empty df -> NULL", { - expect_null(pecotmr:::.cbSumstatPair(NULL, .cbp_makeHandle())) # 317 + expect_null(pecotmr:::.cbSumstatPair(NULL, .cbp_makeHandle())) expect_null(pecotmr:::.cbSumstatPair(data.frame(), .cbp_makeHandle())) }) @@ -894,14 +875,14 @@ test_that(".cbQtlSumStatsBundle: NULL / context / trait filters and empty result extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) - expect_equal(pecotmr:::.cbQtlSumStatsBundle(NULL), list()) # 359 - expect_length(pecotmr:::.cbQtlSumStatsBundle(ss, contexts = "c1"), 1L) # 363 - expect_length(pecotmr:::.cbQtlSumStatsBundle(ss, traitId = "t1"), 1L) # 366 - expect_equal(pecotmr:::.cbQtlSumStatsBundle(ss, contexts = "ghost"), list()) # 368 + expect_equal(pecotmr:::.cbQtlSumStatsBundle(NULL), list()) + expect_length(pecotmr:::.cbQtlSumStatsBundle(ss, contexts = "c1"), 1L) + expect_length(pecotmr:::.cbQtlSumStatsBundle(ss, traitId = "t1"), 1L) + expect_equal(pecotmr:::.cbQtlSumStatsBundle(ss, contexts = "ghost"), list()) }) test_that(".cbGwasSumStatsBundle: NULL -> empty list", { - expect_equal(pecotmr:::.cbGwasSumStatsBundle(NULL), list()) # 390 + expect_equal(pecotmr:::.cbGwasSumStatsBundle(NULL), list()) }) test_that(".cbSumstatPair: varY attaches var_y; NA variant ids fall back to chr:pos", { @@ -917,9 +898,9 @@ test_that(".cbSumstatPair: varY attaches var_y; NA variant ids fall back to chr: stringsAsFactors = FALSE ) pair <- pecotmr:::.cbSumstatPair(df, h, varY = 0.7) - expect_true("var_y" %in% names(pair$sumstat)) # 350 + expect_true("var_y" %in% names(pair$sumstat)) expect_equal(unique(pair$sumstat$var_y), 0.7) - # NA variant_id -> formatVariantId fallback (322-323); no panel overlap -> NULL (330) + # NA variant_id -> formatVariantId fallback; no panel overlap -> NULL dfNA <- data.frame( variant_id = NA_character_, chrom = "chr1", @@ -1026,22 +1007,45 @@ test_that(".cbHarmonizeAlleles aligns opposite-coded sumstats to one canonical ( expect_equal(h$pairs$B$sumstat$z, -3) # B flipped to match }) -test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bundle is skipped", { +test_that("colocboostPipeline(MultiStudy): a study with no bundle is skipped", { mt <- .cbp_makeMultiStudy() # qd (study1, ENSG_A) + ss (Q1, t1) + seen <- list() local_mocked_bindings( extractBlockGenotypes = .cbp_mockExtractor(), .package = "pecotmr" ) local_mocked_bindings( - colocboost = function(...) list(stub = TRUE), + colocboost = function(...) { + seen[[length(seen) + 1L]] <<- list(...) + list(stub = TRUE) + }, .package = "colocboost" ) # traitId="t1" matches the embedded sumstats but not the QtlDataset -> its - # per-study bundle is NULL and skipped (684); the sumstat side still runs. + # per-study bundle is NULL and skipped; the sumstat side still runs. out <- suppressMessages(suppressWarnings( colocboostPipeline(mt, traitId = "t1", xqtlColoc = TRUE) )) - expect_s4_class(out, "ColocBoostResult") + # One xQTL-only run over the summary statistics alone: no individual-level + # data reached colocboost, and no "study1:" outcome was named. + expect_length(seen, 1L) + call <- seen[[1L]] + expect_false(any(is_in(c("X", "Y", "dict_YX"), names(call)))) + expect_identical(call$outcome_names, "Q1:c1:t1") + expect_identical(names(call$sumstat), "Q1:c1:t1") + # The result times that run and records only the summary-level outcome, + # keyed to the embedded sumstats' LD reference. + expect_identical(computingTime(out)$analysis, "xqtl_coloc") + expect_length(out, 0L) + info <- out@outcomeInfo + expect_identical(info$name, "Q1:c1:t1") + expect_identical(info$study, "Q1") + expect_identical(info$dataForm, "sumstats") + expect_length(ldReference(out), 1L) + expect_identical( + ldReference(out)[[info$ldReference]], + ldReference(sumStats(mt))[[1L]] + ) }) @@ -1053,11 +1057,11 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bund # reference panel, on both the QTL and the GWAS sumstat sides. # --------------------------------------------------------------------------- -# @noRd -.cbf_qcd <- function() { +# summaryStatsQc() of the bundled example, run once for the tests below. +.cbf_ss <- local({ data(qtlSumStatsExample, envir = environment()) suppressMessages(summaryStatsQc(qtlSumStatsExample)) -} +}) # @noRd .cbf_n <- function(ss, ...) { @@ -1069,12 +1073,12 @@ test_that("colocboostPipeline(MultiStudyQtlDataset): a study with no usable bund } test_that("colocboost sumstat bundle filters nothing by default", { - ss <- .cbf_qcd() + ss <- .cbf_ss expect_equal(.cbf_n(ss), sum(lengths(ss))) }) test_that("colocboost sumstat bundle drops panel-rare variants", { - ss <- .cbf_qcd() + ss <- .cbf_ss full <- .cbf_n(ss) loose <- .cbf_n(ss, mafCutoff = 0.05) tight <- .cbf_n(ss, mafCutoff = 0.2) @@ -1083,9 +1087,9 @@ test_that("colocboost sumstat bundle drops panel-rare variants", { }) test_that("colocboost RSS cutoffs match .panelVariantFilter", { - ss <- .cbf_qcd() + ss <- .cbf_ss ids <- normalizeVariantId( - as.data.frame( + .sumStatsDf( ss, studyName = ss$study[[1L]], context = ss$context[[1L]], @@ -1097,7 +1101,7 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { expect_equal( .cbf_n(ss, mafCutoff = cut), length(.panelVariantFilter( - ldReference(ss), + ldReference(ss)[[1L]], ids, PanelFilterParam(mafCutoff = cut) )), @@ -1107,8 +1111,8 @@ test_that("colocboost RSS cutoffs match .panelVariantFilter", { }) test_that("colocboost RSS treats MAC as a MAF equivalent", { - ss <- .cbf_qcd() - nSamp <- ncol(ldReference(ss)) + ss <- .cbf_ss + nSamp <- ncol(ldReference(ss)[[1L]]) expect_equal( .cbf_n(ss, macCutoff = 0.1 * 2 * nSamp), .cbf_n(ss, mafCutoff = 0.1) @@ -1116,7 +1120,7 @@ test_that("colocboost RSS treats MAC as a MAF equivalent", { }) test_that("colocboost RSS honours a missingness cutoff", { - ss <- .cbf_qcd() + ss <- .cbf_ss expect_lt(.cbf_n(ss, imissCutoff = 0), sum(lengths(ss))) expect_equal(.cbf_n(ss, imissCutoff = 1), sum(lengths(ss))) }) @@ -1125,15 +1129,15 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { # The row filter indexes df by the FULL-length variant id vector, so the # filtered set has to be passed to the LD build separately rather than by # shrinking that vector. - ss <- .cbf_qcd() - df <- as.data.frame( + ss <- .cbf_ss + df <- .sumStatsDf( ss, studyName = ss$study[[1L]], context = ss$context[[1L]], trait = ss$trait[[1L]], require = "Z" ) - sketch <- ldReference(ss) + sketch <- ldReference(ss)[[1L]] pair <- suppressMessages(.cbSumstatPair( df = df, ldReference = sketch, @@ -1157,7 +1161,7 @@ test_that("colocboost reads a panel's factor and its LdMatrix alike", { skip_if_not_installed("colocboost") data(qtlSumStatsMulticontextExample) ss <- suppressMessages(summaryStatsQc(qtlSumStatsMulticontextExample)) - panel <- ldReference(ss) + panel <- ldReference(ss)[[1L]] withLd <- QtlSumStats( studyName = ss$study, context = ss$context, @@ -1168,7 +1172,7 @@ test_that("colocboost reads a panel's factor and its LdMatrix alike", { unname(computeLd(panel)), variants = SummarizedExperiment::rowRanges(panel) ), - qcInfo = qcInfo(ss) + qcOptions = qcOptions(ss) ) set.seed(1) viaPanel <- suppressWarnings(suppressMessages(colocboostPipeline(ss))) @@ -1179,8 +1183,8 @@ test_that("colocboost reads a panel's factor and its LdMatrix alike", { }) test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { - ss <- .cbf_qcd() - df <- as.data.frame( + ss <- .cbf_ss + df <- .sumStatsDf( ss, studyName = ss$study[[1L]], context = ss$context[[1L]], @@ -1189,7 +1193,7 @@ test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { ) expect_null(suppressMessages(.cbSumstatPair( df = df, - ldReference = ldReference(ss), + ldReference = ldReference(ss)[[1L]], cutoffs = list(mafCutoff = 0.99, macCutoff = 0, imissCutoff = 1) ))) }) @@ -1255,7 +1259,8 @@ test_that("a MultiStudyQtlDataset with no embedded sumstats yields no pairs", { out <- pecotmr:::.cbMultiStudySumstats( multiStudyQtlDatasetExample, contexts = NULL, - traitId = NULL + traitId = NULL, + cisWindow = NULL ) expect_equal(out$qtlPairs, list()) expect_null(out$qtlLdReference) @@ -1312,21 +1317,37 @@ test_that(".cbBuildContextXY skips a context with no shared samples", { test_that(".cbResidualizedX reports why genotypes were unavailable", { local_mocked_bindings( - residualizedGenotypes = function(...) stop("kaboom"), + .qtlResidualizedGenotypes = function(...) stop("kaboom"), .package = "pecotmr" ) # The cause is chained via `parent`, not flattened into the text, so the # rendered message still shows it AND it stays reachable as a condition. # catch_cnd() rather than expect_message(), which returns NULL. cnd <- rlang::catch_cnd( - pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL), + pecotmr:::.cbResidualizedX( + NULL, + "c1", + NULL, + NULL, + NULL, + NULL, + genotypeFilter = pecotmr:::.qtlResolveFilter() + ), classes = "message" ) expect_match(conditionMessage(cnd), "residualized genotypes unavailable") expect_match(conditionMessage(cnd), "kaboom") expect_match(conditionMessage(cnd$parent), "kaboom") expect_null(suppressMessages( - pecotmr:::.cbResidualizedX(NULL, "c1", NULL, NULL, NULL, NULL) + pecotmr:::.cbResidualizedX( + NULL, + "c1", + NULL, + NULL, + NULL, + NULL, + genotypeFilter = pecotmr:::.qtlResolveFilter() + ) )) }) @@ -1409,7 +1430,7 @@ test_that(".cbRunXqtlOnly runs on a summary-level QTL side alone", { expect_null(captured$dict_YX) expect_equal(names(captured$sumstat), c("qtlA", "qtlB")) expect_equal(captured$outcome_names, c("qtlA", "qtlB")) - # focalTrait is honored on the summary-level side too. + # A focal outcome is honored on the summary-level side too. expect_equal(captured$focal_outcome_idx, 2L) # Identical LD matrices dedupe to one, so the dict points both at it. expect_equal(unname(captured$dict_sumstatLD[, "LD"]), c(1L, 1L)) @@ -1463,12 +1484,12 @@ test_that(".cbRunVariants: xqtlColoc runs on a QTL-only sumstat bundle", { xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, - focalTrait = NULL, + focal = NULL, methodArgs = ColocboostOptions(), qtlSumstatBundle = qtlOnly )) expect_equal(called, "xqtl") - expect_false(is.null(computingTime(out)$Analysis$xqtl_coloc)) + expect_true(is_in("xqtl_coloc", computingTime(out)$analysis)) }) test_that(".cbRunVariants warns instead of silently skipping an analysis", { @@ -1491,7 +1512,7 @@ test_that(".cbRunVariants warns instead of silently skipping an analysis", { xqtlColoc = FALSE, jointGwas = TRUE, separateGwas = TRUE, - focalTrait = NULL, + focal = NULL, methodArgs = ColocboostOptions() )) ) @@ -1515,13 +1536,13 @@ test_that(".cbRunVariants warns when xqtlColoc has only GWAS sumstats", { xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, - focalTrait = NULL, + focal = NULL, methodArgs = ColocboostOptions(), qtlSumstatBundle = pecotmr:::.cbMergeSumstatBundles(list()) )), "xqtlColoc = TRUE was requested" ) - expect_null(computingTime(out)$Analysis$xqtl_coloc) + expect_false(is_in("xqtl_coloc", computingTime(out)$analysis)) }) test_that("ColocboostOptions() options reach the engine by name", { @@ -1550,7 +1571,7 @@ test_that("ColocboostOptions() options reach the engine by name", { xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, - focalTrait = NULL, + focal = NULL, methodArgs = ColocboostOptions(M = 3L, stop_thresh = 0.02), qtlSumstatBundle = qtlOnly )) @@ -1563,15 +1584,14 @@ test_that("ColocboostOptions() options reach the engine by name", { test_that(".cbAppendGwasPairs disambiguates a colliding study key", { local_mocked_bindings( .cbRequireSumStatsQc = function(...) invisible(NULL), - .cbGwasSumStatsBundle = function(gwasSumStats, cutoffs) { + .cbGwasSumStatsBundle = function(gwasSumStats, window, cutoffs) { list(dup = "GWAS") }, .package = "pecotmr" ) out <- pecotmr:::.cbAppendGwasPairs( list(dup = "QTL", other = "X"), - "notNull", - qtlLdReference = NULL + "notNull" ) # The QTL pair keeps its key; the GWAS pair is suffixed rather than # overwriting it. @@ -1591,8 +1611,8 @@ test_that("colocboostPipeline forwards residualizationParam to both sides", { # Y together, so a bundle that reached only the genotypes would # residualize the two against different covariate sets. data(qtlDatasetExample, envir = environment()) - origG <- residualizedGenotypes - origP <- residualizedPhenotypes + origG <- pecotmr:::.qtlResidualizedGenotypes + origP <- pecotmr:::.qtlResidualizedPhenotypes seen <- new.env(parent = emptyenv()) note <- function(which, ra) { assign( @@ -1605,7 +1625,7 @@ test_that("colocboostPipeline forwards residualizationParam to both sides", { ) } local_mocked_bindings( - residualizedGenotypes = function( + .qtlResidualizedGenotypes = function( x, ..., residualizationParam = ResidualizationParam() @@ -1613,7 +1633,7 @@ test_that("colocboostPipeline forwards residualizationParam to both sides", { note("geno", residualizationParam) origG(x, ..., residualizationParam = residualizationParam) }, - residualizedPhenotypes = function( + .qtlResidualizedPhenotypes = function( x, ..., residualizationParam = ResidualizationParam() @@ -1631,3 +1651,396 @@ test_that("colocboostPipeline forwards residualizationParam to both sides", { expect_equal(unique(get("geno", envir = seen)), "FALSE") expect_equal(unique(get("pheno", envir = seen)), "FALSE") }) + +# =========================================================================== +# One outcome per GWAS study; the focal outcome +# =========================================================================== + +# One GWAS study over three rows: two LD blocks on chr1 (100-300, 400-500) +# and one on chr2. +.cbp_makeBlockedGwas <- function() { + gr <- GenomicRanges::GRanges( + c(rep("chr1", 5L), "chr2"), + IRanges::IRanges(c(100L * (1:5), 100L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c(sprintf("chr1:%d:A:G", 100L * (1:5)), "chr2:100:A:G"), + A1 = rep("A", 6L), + A2 = rep("G", 6L), + Z = seq_len(6L) / 10, + N = rep(1000L, 6L) + ) + GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + ldReference = .cbp_makeHandle(), + qcOptions = list(ok = 1), + region = GenomicRanges::GRanges( + c("chr1", "chr1", "chr2"), + IRanges::IRanges(c(1L, 301L, 1L), c(300L, 1000L, 1000L)) + ) + ) +} + +# Two GWAS studies over the fixtures' five chr1 variants. +.cbp_makeTwoGwas <- function() { + gr <- .cbp_makeGwasSumStats()[[1L]] + GwasSumStats( + studyName = c("G1", "G2"), + entry = list(gr, gr), + genome = "hg19", + ldReference = .cbp_makeHandle(), + qcOptions = list(ok = 1) + ) +} + +test_that("a GWAS study is one outcome over the rows the QTL data reach", { + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + gws <- .cbp_makeBlockedGwas() + expect_equal(nrow(gws), 3L) + chr1 <- sprintf("chr1:%d:A:G", 100L * (1:5)) + # A window reaching both chr1 blocks gets their union as one outcome; the + # chr2 row is not read. + both <- pecotmr:::.cbGwasSumStatsBundle( + gws, + window = GenomicRanges::GRanges("chr1", IRanges::IRanges(150L, 450L)) + ) + expect_named(both, "G1") + expect_setequal(both$G1$sumstat$variant, chr1) + expect_equal(both$G1$study, "G1") + # A window inside one block reads that block alone. + one <- pecotmr:::.cbGwasSumStatsBundle( + gws, + window = GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, 200L)) + ) + expect_setequal(one$G1$sumstat$variant, chr1[1:3]) + # A study none of whose rows the QTL data reach is left out, and said so. + expect_message( + none <- pecotmr:::.cbGwasSumStatsBundle( + gws, + window = GenomicRanges::GRanges("chr3", IRanges::IRanges(1L, 9L)) + ), + "leaving out GWAS G1" + ) + expect_length(none, 0L) +}) + +test_that("a GWAS study's overlapped rows must share one LD reference", { + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + gws <- pecotmr:::.withRowLdRefs( + .cbp_makeBlockedGwas(), + list(.cbp_makeHandle(), .cbp_makeLdMatrix(), .cbp_makeHandle()) + ) + expect_error( + pecotmr:::.cbGwasSumStatsBundle( + gws, + window = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(150L, 450L) + ) + ), + "GWAS study 'G1' the QTL data overlap use 2 different LD references" + ) +}) + +test_that(".cbAssertFocalOutcome takes NULL or a named QTL vector", { + ok <- list( + NULL, + c(trait = "ENSG1"), + c(study = "S1", context = "brain", trait = "ENSG1") + ) + for (x in ok) { + expect_invisible(pecotmr:::.cbAssertFocalOutcome(x, TRUE)) + } + # A GWAS study name is not one: its separate run is the focal one. + bad <- list( + NA, + "G1", + 1, + c("G1", "G2"), + c(gene = "ENSG1"), + c("brain", trait = "ENSG1"), + c(trait = NA_character_), + character(0), + list(trait = "ENSG1") + ) + for (x in bad) { + expect_error( + pecotmr:::.cbAssertFocalOutcome(x, TRUE), + "must be NULL or a named" + ) + } + # Only the xQTL-only run is ever focal on a QTL outcome. + expect_error( + pecotmr:::.cbAssertFocalOutcome(c(trait = "ENSG1"), FALSE), + "but .xqtlColoc. is FALSE" + ) + expect_invisible(pecotmr:::.cbAssertFocalOutcome(NULL, FALSE)) +}) + +test_that(".cbResolveFocal: the one QTL outcome named, or none", { + qtlInfo <- tibble::tibble( + name = c("brain_ENSG1", "liver_ENSG1", "Q1:c1:t1"), + study = c("S1", "S1", "Q1"), + context = c("brain", "liver", "c1"), + trait = c("ENSG1", "ENSG1", "t1") + ) + resolve <- function(focal) pecotmr:::.cbResolveFocal(focal, qtlInfo) + expect_null(resolve(NULL)) + # A QTL outcome, by as many parts as it takes to name one. + expect_equal(resolve(c(context = "brain", trait = "ENSG1")), "brain_ENSG1") + expect_equal(resolve(c(trait = "t1")), "Q1:c1:t1") + expect_error(resolve(c(trait = "ENSG1")), "matches 2 QTL") + expect_error(resolve(c(trait = "nope")), "matches no QTL") +}) + +test_that("the joint run is non-focal; focalOutcome reaches xQTL-only", { + seen <- list() + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + local_mocked_bindings( + colocboost = function(...) { + seen[[length(seen) + 1L]] <<- list(...) + list(stub = TRUE) + }, + .package = "colocboost" + ) + # Built once: the runs below differ only in their flags. + qtl <- .cbp_makeQtlSumStats() + oneGwas <- .cbp_makeGwasSumStats() + run <- function(gws, ...) { + seen <<- list() + suppressMessages(colocboostPipeline(qtl, gwasSumStats = gws, ...)) + seen + } + # One GWAS: the joint run and its separate run fit the same outcomes, + # one non-focal and one focal on the GWAS. + calls <- run( + oneGwas, + xqtlColoc = FALSE, + jointGwas = TRUE, + separateGwas = TRUE + ) + expect_length(calls, 2L) + expect_equal(calls[[1L]]$outcome_names, c("Q1:c1:t1", "G1")) + expect_null(calls[[1L]]$focal_outcome_idx) + expect_equal(calls[[2L]]$outcome_names, c("Q1:c1:t1", "G1")) + expect_equal(calls[[2L]]$focal_outcome_idx, 2L) + # Several GWAS studies leave the joint run non-focal too. + twoGwas <- run(.cbp_makeTwoGwas(), xqtlColoc = FALSE, jointGwas = TRUE) + expect_null(twoGwas[[1L]]$focal_outcome_idx) + # A QTL outcome is focal in the xQTL-only run, and only there. + calls <- run(oneGwas, jointGwas = TRUE, focalOutcome = c(trait = "t1")) + expect_equal(calls[[1L]]$focal_outcome_idx, 1L) + expect_null(calls[[2L]]$focal_outcome_idx) + expect_error( + run( + oneGwas, + xqtlColoc = FALSE, + jointGwas = TRUE, + focalOutcome = c(trait = "t1") + ), + "but .xqtlColoc. is FALSE" + ) + expect_error( + run(oneGwas, jointGwas = TRUE, focalOutcome = "G1"), + "must be NULL or a named" + ) +}) + +test_that("a QTL sumstat outcome records the tuple it came from", { + pairs <- list( + `Q1:c1:t1` = list(study = "Q1", context = "c1", trait = "t1"), + G1 = list(study = "G1") + ) + bundle <- list(sumstat = list(`Q1:c1:t1` = 1, G1 = 2)) + info <- pecotmr:::.cbOutcomeInfo( + NULL, + bundle, + FALSE, + c(`Q1:c1:t1` = "ld1", G1 = "ld1"), + pecotmr:::.cbPairsInfo(pairs) + ) + expect_equal(info$study, c("Q1", "G1")) + expect_equal(info$context, c("c1", NA)) + expect_equal(info$trait, c("t1", NA)) +}) + +test_that("a focalOutcome vector with no QTL outcomes to match says so", { + noQtl <- tibble::tibble( + name = character(0), + study = character(0), + context = character(0), + trait = character(0) + ) + expect_error( + pecotmr:::.cbResolveFocal(c(trait = "t1"), noQtl), + "The QTL outcomes are: none" + ) +}) + +test_that("an outcome whose variants its LD reference lacks is left out", { + # The fixtures' LdMatrix holds chr1:100-500; these sit at 1100-1500. + ids <- sprintf("chr1:%d:A:G", 1100L + 100L * (0:4)) + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(1100L + 100L * (0:4), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = ids, + A1 = rep("A", 5L), + A2 = rep("G", 5L), + Z = seq_len(5L) / 10, + N = rep(1000L, 5L) + ) + qss <- QtlSumStats( + studyName = "Q1", + context = "c1", + trait = "t1", + entry = list(gr), + genome = "hg19", + ldReference = .cbp_makeLdMatrix(), + qcOptions = list(ok = 1) + ) + expect_null(pecotmr:::.cbQtlEntryPair(1L, qss, NULL)) + gws <- GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + ldReference = .cbp_makeLdMatrix(), + qcOptions = list(ok = 1) + ) + expect_length(pecotmr:::.cbGwasSumStatsBundle(gws), 0L) +}) + +test_that(".cbQtlWindow places the QTL variants it can parse", { + asX <- function(ids) { + list(X = list(matrix(0, 2L, length(ids), dimnames = list(NULL, ids)))) + } + # Nothing placed -- no QTL side, or only rsIDs -- leaves every GWAS row in. + expect_null(pecotmr:::.cbQtlWindow(NULL, list())) + expect_null(pecotmr:::.cbQtlWindow(asX(c("rs1", "rs2")), list())) + window <- pecotmr:::.cbQtlWindow( + asX(c("1:100:A:G", "rs2", "chr1:400:C:T")), + list() + ) + expect_equal(as.character(GenomicRanges::seqnames(window)), "chr1") + expect_equal(GenomicRanges::start(window), 100L) + expect_equal(GenomicRanges::end(window), 400L) +}) + +test_that(".cbQtlVariants places the variants every QTL outcome reads", { + asX <- function(ids) { + list(X = list(matrix(0, 2L, length(ids), dimnames = list(NULL, ids)))) + } + expect_null(pecotmr:::.cbQtlVariants(NULL, list())) + expect_null(pecotmr:::.cbQtlVariants(asX("rs1"), list())) + placed <- pecotmr:::.cbQtlVariants( + asX(c("1:100:A:G", "rs2")), + list(q1 = list(variantIds = c("chr1:100:A:G", "chr1:700:C:T"))) + ) + expect_identical(as.character(placed), c("chr1:100", "chr1:700")) +}) + +test_that("colocboost refuses QTL data reaching past a given block", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:5), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = 1, + N = 100L + ) + gws <- GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + qcOptions = list(ok = 1), + region = GenomicRanges::GRanges("chr1:1-550") + ) + qtl <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(300L, 600L), width = 1L) + ) + expect_error( + pecotmr:::.cbAppendGwasPairs(list(), gws, qtlVariants = qtl), + "the QTL data: 1 variant(s) past the end of block chr1:1-550", + fixed = TRUE + ) + # Without QTL variants to place there is nothing to check. + expect_null(pecotmr:::.cbCheckBlockReach(NULL, gws)) +}) + +test_that("colocboostPipeline(QtlSumStats) lays a cisWindow around traitPos", { + expect_error( + colocboostPipeline(.cbp_makeQtlSumStats(), cisWindow = 1000), + "colocboostPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) + # Naming a context reaches the same check: the window is laid on the + # tuples colocboost's own selection keeps. + expect_error( + colocboostPipeline( + .cbp_makeQtlSumStats(), + contexts = "c1", + cisWindow = 1000 + ), + "colocboostPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) +}) + +test_that("colocboostPipeline(MSQD) lays cisWindow on its summary statistics", { + local_mocked_bindings( + extractBlockGenotypes = .cbp_mockExtractor(), + .package = "pecotmr" + ) + ss <- .cbp_makeQtlSumStats() + ss$traitPos <- GenomicRanges::GRanges("chr1:300") + mt <- MultiStudyQtlDataset( + qtlDatasets = list( + study1 = .cbp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + ), + sumStats = ss + ) + pairs <- pecotmr:::.cbMultiStudySumstats(mt, NULL, NULL, 100)$qtlPairs + expect_identical(as.character(pairs[[1L]]$span), "chr1:200-400") + # A summary-statistics study without a trait position is an error, as it + # is on its own. + expect_error( + colocboostPipeline(.cbp_makeMultiStudy(), cisWindow = 100), + "colocboostPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) +}) + +# =========================================================================== +# .cbToResultObject +# =========================================================================== + +test_that("separate_gwas runs are keyed by gwasStudy", { + # The three analyses are not parallel: separate_gwas is a named list one + # level deeper, so without gwasStudy its sets would be indistinguishable. + raw <- list( + xqtl_coloc = NULL, + joint_gwas = NULL, + separate_gwas = list(G1 = .cbr_fake(), G2 = .cbr_fake()), + computing_time = list() + ) + x <- .cbToResultObject(raw, .cbr_info()) + expect_equal(nrow(x), 2L) + expect_equal(x$analysis, rep("separate_gwas", 2L)) + expect_setequal(x$gwasStudy, c("G1", "G2")) +}) diff --git a/tests/testthat/test_cpp11.R b/tests/testthat/test_cpp11.R index 2818c855..353583c7 100644 --- a/tests/testthat/test_cpp11.R +++ b/tests/testthat/test_cpp11.R @@ -20,8 +20,6 @@ "bgenSampleIdsCpp", "dentistIterativeImpute", "dentistIterativeImputeFactor", - "lassosumRssCpp", - "lassosumRssFactorCpp", "ldThresholdComponents", "penalizedRssCpp", "penalizedRssFactorCpp", diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index 010d59d5..c49fcacb 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -179,15 +179,24 @@ test_that("maxNumVariants with variantsToKeep retains the specified variants", { }) test_that("a degenerate fold (empty train/test) is skipped, not errored", { + # One fold holding every sample leaves nothing to train on: the fold is + # skipped before any fit, so nothing is predicted or scored. d <- mkXY(n = 10) sp <- data.frame(Sample = rownames(d$X), Fold = rep(1L, nrow(d$X))) + fits <- 0L + countingFit <- function(...) { + fits <<- fits + 1L + mockFitFold(...) + } r <- suppressMessages(cv( d$X, d$Y, samplePartitions = sp, - fitFold = mockFitFold + fitFold = countingFit )) - expect_true(all(is.na(r$prediction[["mock_predicted"]]))) + expect_equal(fits, 0L) + expect_length(r$prediction, 0L) + expect_length(r$performance, 0L) }) test_that("zero-variance predictions yield NA metrics with a message", { @@ -213,6 +222,7 @@ test_that("zero-variance predictions yield NA metrics with a message", { }) test_that("the parallel fold path matches the serial one", { + skip_on_os("windows") d <- mkXY(n = 40, seed = 7) set.seed(1) r1 <- suppressMessages(cv( @@ -220,7 +230,7 @@ test_that("the parallel fold path matches the serial one", { d$Y, fold = 4, fitFold = mockFitFold, - numThreads = 1 + BPPARAM = BiocParallel::SerialParam() )) set.seed(1) r2 <- suppressMessages(cv( @@ -228,7 +238,7 @@ test_that("the parallel fold path matches the serial one", { d$Y, fold = 4, fitFold = mockFitFold, - numThreads = 2 + BPPARAM = BiocParallel::MulticoreParam(2) )) expect_equal(r1$prediction, r2$prediction) }) @@ -322,13 +332,68 @@ test_that("sample names are synthesized when neither matrix carries rownames", { expect_equal(rownames(out$Y), rownames(out$X)) }) -test_that("numThreads = -1 asks BiocParallel for the worker count", { - # -1 means "all available"; anything else is capped at what is available. - expect_equal( - pecotmr:::.cvNumCores(-1), - BiocParallel::multicoreWorkers() +test_that("BPPARAM must be a BiocParallelParam", { + expect_error(pecotmr:::.assertBpparam(2), "must be a BiocParallelParam") + expect_error( + CrossValidationParam(BPPARAM = 4), + "must be a BiocParallelParam" + ) +}) + +test_that("the workers draw from a seeded copy of the caller's BPPARAM", { + bp <- BiocParallel::SerialParam() + # `seed` first, then the param's own RNGseed, and the caller's param is + # left as it was. + expect_identical( + BiocParallel::bpRNGseed(pecotmr:::.seededBpparam(bp, 7L)), + 7L + ) + expect_null(BiocParallel::bpRNGseed(bp)) + own <- BiocParallel::SerialParam(RNGseed = 3L) + expect_identical( + BiocParallel::bpRNGseed(pecotmr:::.seededBpparam(own)), + 3L + ) + # Neither: one draw from the session RNG, so set.seed() still governs. + set.seed(11) + a <- BiocParallel::bpRNGseed(pecotmr:::.seededBpparam(bp)) + set.seed(11) + b <- BiocParallel::bpRNGseed(pecotmr:::.seededBpparam(bp)) + expect_identical(a, b) +}) + +test_that("a worker's error is raised with its own message", { + boom <- function(i) { + if (i == 2L) { + rlang::abort("element two failed") + } + i + } + expect_error( + pecotmr:::.bpMap(1:3, boom, BPPARAM = BiocParallel::SerialParam()), + "^element two failed$" + ) + expect_identical( + pecotmr:::.bpMap(1:2, identity, BPPARAM = BiocParallel::SerialParam()), + list(1L, 2L) ) - expect_equal(pecotmr:::.cvNumCores(1), 1) +}) + +test_that("a threaded engine counts only workers on this machine", { + expect_identical( + pecotmr:::.bpLocalThreads(BiocParallel::SerialParam(), "f"), + 1L + ) + expect_identical( + pecotmr:::.bpLocalThreads(BiocParallel::MulticoreParam(3), "f"), + 3L + ) + rlang::local_options(rlib_message_verbosity = "verbose") + expect_message( + n <- pecotmr:::.bpLocalThreads(BiocParallel::SnowParam(4), "f"), + "f: the workers of a SnowParam need not run on this machine" + ) + expect_identical(n, 1L) }) test_that("a seed makes a CV call reproducible without leaking RNG state", { @@ -350,6 +415,21 @@ test_that(".cvPartitionKey answers NULL when there is no partition to key", { expect_null(pecotmr:::.cvPartitionKey(NULL)) }) +test_that(".cvPartitionKey ignores row order but not fold assignment", { + sp <- data.frame(Sample = c("s1", "s2", "s3"), Fold = c(1L, 2L, 1L)) + shuffled <- sp[c(3, 1, 2), ] + expect_identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(shuffled) + ) + moved <- sp + moved$Fold <- c(1L, 1L, 2L) + expect_false(identical( + pecotmr:::.cvPartitionKey(sp), + pecotmr:::.cvPartitionKey(moved) + )) +}) + test_that("sumstats inputs ignore residualization but refuse crossValidation", { # The asymmetry follows from the defaults, not from taste. CV is off # unless asked for (folds = 0), so a non-default value on a @@ -430,3 +510,46 @@ test_that("CrossValidationParam(fitFullData) is validated at construction", { "fitFullData" ) }) + +test_that("a BPPARAM other than SerialParam() is a cross-validation request", { + expect_silent(pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(BPPARAM = BiocParallel::SerialParam()), + "fineMappingPipeline", + "QtlSumStats" + )) + expect_error( + pecotmr:::.cvRefuseOnSumstats( + CrossValidationParam(BPPARAM = BiocParallel::MulticoreParam(2)), + "fineMappingPipeline", + "QtlSumStats" + ), + "Remove CrossValidationParam(BPPARAM)", + fixed = TRUE + ) +}) + +test_that("a BiocParallel report without a worker error is raised as is", { + cnd <- structure( + class = c("bplist_error", "bperror", "error", "condition"), + list(message = "no element failed", call = NULL) + ) + attr(cnd, "result") <- list(1L) + expect_error(pecotmr:::.bpRaiseFirstError(cnd), "no element failed") +}) + +# =========================================================================== +# .cvSamplePartition and .cvMetricRow +# =========================================================================== + +test_that(".cvSamplePartition partitions every sample into the requested folds", { + part <- pecotmr:::.cvSamplePartition(paste0("s", 1:20), fold = 4L) + expect_setequal(part$Sample, paste0("s", 1:20)) + expect_setequal(sort(unique(part$Fold)), 1:4) + expect_equal(nrow(part), 20L) +}) + +test_that(".cvMetricRow: < 3 usable predictions -> all-NA row", { + expect_true(all(is.na(pecotmr:::.cvMetricRow(c(1, 2), c(1, 2))))) + ok <- pecotmr:::.cvMetricRow(c(1, 2, 3, 4, 5), c(1.1, 2, 2.9, 4, 5)) + expect_false(is.na(ok[["rsq"]])) +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index 9c3a35a7..d15dd4e4 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -28,7 +28,7 @@ context("ctwasPipeline") format = "plink2", snpInfo = data.frame( SNP = snpIds, - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = positions, A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -124,7 +124,7 @@ context("ctwasPipeline") genome = "hg19", ldReference = .ctp_makeHandle(snp_n = 6L * n), blockId = blockIds, - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } @@ -132,7 +132,7 @@ context("ctwasPipeline") # weights; it has to name five of them, one per weight. The default sits # inside block 1 -- pass 7:11 for a gene that lives in block 2. .ctp_makeTwasWeights <- function(variantIdx = 1:5) { - e <- twasWeightsRow( + e <- TwasWeightsRow( variantIds = map_chr(variantIdx, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) @@ -166,7 +166,7 @@ context("ctwasPipeline") cs_95 = rep("susie_1", 5), stringsAsFactors = FALSE ) - fe <- fineMappingRow(variantIds = vids, susieFit = list(), topLoci = tl) + fe <- FineMappingRow(variantIds = vids, susieFit = list(), topLoci = tl) QtlFineMappingResult( studyName = "Q1", context = "c1", @@ -209,7 +209,8 @@ test_that("ctwasPipeline: rejects a per-region list of GwasSumStats", { expect_error( ctwasPipeline( gwasSumStats = list(block1 = ss, block2 = ss), - twasWeights = .ctp_makeTwasWeights() + twasWeights = .ctp_makeTwasWeights(), + method = "susie" ), "must be a GwasSumStats whose elements are LD blocks" ) @@ -220,7 +221,8 @@ test_that("ctwasPipeline: rejects a single-block named list", { expect_error( ctwasPipeline( gwasSumStats = .ctp_makeGwasSumstats(blockIds = "block1"), - twasWeights = list(block1 = .ctp_makeTwasWeights()) + twasWeights = list(block1 = .ctp_makeTwasWeights()), + method = "susie" ), "at least two LD blocks" ) @@ -234,7 +236,8 @@ test_that("ctwasPipeline: rejects un-QCd GwasSumStats in any region", { expect_error( ctwasPipeline( gwasSumStats = ss_noqc, - twasWeights = list(block1 = tw, block2 = tw) + twasWeights = list(block1 = tw, block2 = tw), + method = "susie" ), "has no QC record" ) @@ -249,7 +252,8 @@ test_that("ctwasPipeline: rejects twasWeights keys not present in gwasSumStats", gwasSumStats = .ctp_makeGwasSumstats( blockIds = c("blockA", "blockB") ), - twasWeights = list(blockA = tw, blockC = tw) + twasWeights = list(blockA = tw, blockC = tw), + method = "susie" ), "key.*not present in.*gwasSumStats" ) @@ -269,7 +273,8 @@ test_that("assembleCtwasInputs: allows twasWeights keys to be a subset of gwasSu expect_warning( inputs <- assembleCtwasInputs( gwasSumStats = ss, - twasWeights = list(block1 = tw) + twasWeights = list(block1 = tw), + method = "susie" ), "share 6 variant" ) @@ -290,7 +295,7 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to context = "c1", trait = "t1", method = "susie", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0), weightStandardized = TRUE @@ -304,11 +309,13 @@ test_that("assembleCtwasInputs: accepts a QtlFineMappingResult weight source (to ) itw <- assembleCtwasInputs( gwasSumStats = ss, - twasWeights = list(block1 = tw_std, block2 = tw_std) + twasWeights = list(block1 = tw_std, block2 = tw_std), + method = "susie" ) ifmr <- assembleCtwasInputs( gwasSumStats = ss, - twasWeights = list(block1 = fmr, block2 = fmr) + twasWeights = list(block1 = fmr, block2 = fmr), + method = "susie" ) # Same gene keys, and the resolved weights match the standardized TwasWeights. expect_equal(names(ifmr$weights), names(itw$weights)) @@ -342,13 +349,13 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { entry = list(gr), genome = "hg19", ldReference = .ctp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } ss1 <- mkBlockGss("G1", map_chr(1:3, .ctp_snpId)) ss2 <- mkBlockGss("G2", map_chr(4:6, .ctp_snpId)) # Cross-boundary weights: v2..v5 (4 variants spanning both blocks). - crossEntry <- twasWeightsRow( + crossEntry <- TwasWeightsRow( variantIds = map_chr(2:5, .ctp_snpId), weights = c(0.1, 0.2, 0.3, 0.4) ) @@ -368,7 +375,8 @@ test_that("assembleCtwasInputs: boundary gene fits per-region, spans all", { mcols(both)$blockId <- c("block1", "block2") inputs <- assembleCtwasInputs( gwasSumStats = both, - twasWeights = list(block1 = tw) + twasWeights = list(block1 = tw), + method = "susie" ) # ctwas fine-maps one region at a time, so the FITTED vector holds only the # variants this block has LD for -- handing susie_rss the other two produces @@ -394,7 +402,8 @@ test_that("ctwasPipeline: a bare TwasWeights is a FLAT source, placed by region" expect_error( ctwasPipeline( gwasSumStats = .ctp_makeGwasSumstats(), - twasWeights = .ctp_makeTwasWeights() + twasWeights = .ctp_makeTwasWeights(), + method = "susie" ), "no `traitPos` provenance" ) @@ -407,7 +416,8 @@ test_that("ctwasPipeline: rejects non-GRanges twasZ", { ctwasPipeline( gwasSumStats = inp$gwasSumStats, twasWeights = inp$twasWeights, - twasZ = "not a GRanges" + twasZ = "not a GRanges", + method = "susie" ), "must be a GRanges" ) @@ -437,18 +447,33 @@ test_that(".ctwasRequireMatchingLdRefs: NULL twas-side handle is allowed", { context = "c1", trait = "t1", method = "susie", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), weights = rep(0.1, 5) )), ldReference = NULL ) expect_silent(pecotmr:::.ctwasRequireMatchingLdRefs( - twLd = NULL, - gwasLd = .ctp_makeHandle() + twNoLd, + .ctp_makeGwasSumstats() )) }) +# One weight row on `handle`, for the region-level match checks. +.ctp_weightsOn <- function(handle) { + TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), + weights = rep(0.1, 3) + )), + ldReference = handle + ) +} + 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 @@ -459,22 +484,27 @@ test_that(".ctwasRequireMatchingLdRefs: differently trimmed panels ok", { # 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("pecotmrLdReferenceOverlap-ctwasPipeline") - twLd <- .ctp_makeHandle(snp_n = 5L) - gwasLd <- .ctp_makeHandle(snp_n = 6L) + tw <- .ctp_weightsOn(.ctp_makeHandle(snp_n = 5L)) + gwas <- pecotmr:::.withRowLdRefs( + .ctp_makeGwasSumstats(), + .ctp_makeHandle(snp_n = 6L) + ) expect_warning( - expect_null(pecotmr:::.ctwasRequireMatchingLdRefs(twLd, gwasLd)), + expect_null(pecotmr:::.ctwasRequireMatchingLdRefs(tw, gwas)), "share 5 variant" ) }) 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:::.ctwasRequireMatchingLdRefs(twLd, gwasLd), + pecotmr:::.ctwasRequireMatchingLdRefs( + .ctp_weightsOn(.ctp_makeHandle(snp_n = 3L)), + pecotmr:::.withRowLdRefs(.ctp_makeGwasSumstats(), gwasLd) + ), "share no variant" ) }) @@ -586,25 +616,27 @@ test_that(".ctwasSnpInfoForGwasBlock: keeps rows the GWAS spells flipped", { expect_equal(keep$id, flippedPanel$id) }) -test_that(".ctwasBuildSingleRegionInfo: pulls chrom + bp span from the GWAS block entry", { - # Bounds come from the block's GWAS variants (the GwasSumStats entry), NOT - # the LD sketch — many blocks can share one whole-chromosome LD payload. - ri <- pecotmr:::.ctwasBuildSingleRegionInfo( - "block1", - .ctp_makeGwasSumstats(blockIds = "block1") +test_that(".ctwasBuildSingleRegionInfo: a given region bounds the block", { + # The LD block a GWAS was split by is its window, however much narrower + # its variants are. + gss <- GwasSumStats( + studyName = "G1", + entry = list(.ctp_blockVariants(1L)), + genome = "hg19", + region = GenomicRanges::GRanges("chr1:1-1000") ) - expect_equal(ri$region_id, "block1") - expect_equal(ri$chrom, 1L) - expect_equal(ri$start, 100L) - expect_equal(ri$stop, 600L) + ri <- pecotmr:::.ctwasBuildSingleRegionInfo("chr1_1_1000", gss) + expect_equal(ri$start, 1L) + expect_equal(ri$stop, 1001L) }) test_that(".ctwasBuildSingleRegionInfo: uses the block entry span, not the wider shared LD sketch", { # Regression: many LD blocks can share one whole-chromosome LD payload, so - # the sketch span (here BP 100-600) is NOT the block's span. The entry here - # covers only 200-400; region bounds must follow the entry, otherwise every - # block collapses to the whole-chromosome span and every SNP is assigned to - # every region (inflating SNP group_size and crushing the gene PIP). + # the sketch span (here BP 100-1200) is NOT the block's span. The entry + # here covers only 200-400; region bounds must follow the entry, otherwise + # every block collapses to the whole-chromosome span and every SNP is + # assigned to every region (inflating SNP group_size and crushing the gene + # PIP). gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges(start = c(200L, 300L, 400L), width = 1L) @@ -621,11 +653,14 @@ test_that(".ctwasBuildSingleRegionInfo: uses the block entry span, not the wider entry = list(gr), genome = "hg19", ldReference = .ctp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) ri <- pecotmr:::.ctwasBuildSingleRegionInfo("blockX", gss) + expect_equal(ri$region_id, "blockX") + expect_equal(ri$chrom, 1L) + # cTWAS reads [start, stop), so stop is one past the window's last base. expect_equal(ri$start, 200L) # entry min, not sketch min (100) - expect_equal(ri$stop, 400L) # entry max, not sketch max (600) + expect_equal(ri$stop, 401L) # one past entry max, not sketch max (1200) }) test_that(".ctwasBuildSingleRegionInfo: multi-chromosome block entry errors", { @@ -645,7 +680,7 @@ test_that(".ctwasBuildSingleRegionInfo: multi-chromosome block entry errors", { entry = list(gr), genome = "hg19", ldReference = .ctp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) expect_error( pecotmr:::.ctwasBuildSingleRegionInfo("block1", gss), @@ -699,7 +734,7 @@ test_that(".ctwasLdPanelKey: errors when no candidate file exists", { format = "plink2", snpInfo = data.frame( SNP = "chr1:100:A:G", - CHR = "1", + CHR = "chr1", BP = 100L, A1 = "A", A2 = "G", @@ -758,15 +793,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:::.ldRefRanges(ldReference(ss))), 12L) + expect_equal(length(pecotmr:::.ldRefRanges(ldReference(ss)[[1L]])), 12L) byBlock <- pecotmr:::.ctwasGwasByBlock(ss) sizes <- map_int(byBlock, function(b) { - length(pecotmr:::.ldRefRanges(ldReference(b))) + length(pecotmr:::.ldRefRanges(ldReference(b)[[1L]])) }) 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:::.ldRefRanges(ldReference(b))) + GenomicRanges::start(pecotmr:::.ldRefRanges(ldReference(b)[[1L]])) }) expect_equal(pos[[1L]], 100L * (1:6)) expect_equal(pos[[2L]], 100L * (7:12)) @@ -775,7 +810,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, ldReference) + sketches <- map(byBlock, function(b) ldReference(b)[[1L]]) tokens <- pecotmr:::.ctwasRegionLdTokens(names(byBlock), sketches) expect_length(unique(unname(tokens)), 2L) expect_true(all(file.exists(tokens))) @@ -799,7 +834,8 @@ test_that("assembleCtwasInputs: each region gets its own block-sized panel", { ) out <- assembleCtwasInputs( gwasSumStats = inp$gwasSumStats, - twasWeights = inp$twasWeights + twasWeights = inp$twasWeights, + method = "susie" ) expect_length(unique(out$LD_map$LD_file), 2L) panels <- pecotmr:::.ctwasCachedPanels(out) @@ -819,7 +855,8 @@ test_that(".ctwasResolveLdPaths: re-mints sentinels lost with the session", { ) out <- assembleCtwasInputs( gwasSumStats = inp$gwasSumStats, - twasWeights = inp$twasWeights + twasWeights = inp$twasWeights, + method = "susie" ) before <- pecotmr:::.ctwasCachedPanels(out) # The sentinels live in the session tempdir; a payload reloaded in a new @@ -835,24 +872,8 @@ test_that(".ctwasResolveLdPaths: re-mints sentinels lost with the session", { expect_equal(loader(tokens[[2L]]), pecotmr:::.ctwasPanelLd(before[[2L]])) }) -test_that(".ctwasResolveMethod: caller-supplied method wins when present", { - e <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.1, 0.2, 0.3) - ) - tw <- TwasWeights( - studyName = "Q1", - context = "c1", - trait = "t1", - method = "mrash", - entry = list(e), - ldReference = .ctp_makeHandle() - ) - expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw), "mrash"), "mrash") -}) - -test_that(".ctwasResolveMethod: caller-supplied unknown method errors", { - e <- twasWeightsRow( +test_that(".ctwasResolveMethod: no-ensemble TwasWeights need `method`", { + e <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) ) @@ -864,90 +885,18 @@ test_that(".ctwasResolveMethod: caller-supplied unknown method errors", { entry = list(e), ldReference = .ctp_makeHandle() ) - expect_error( - pecotmr:::.ctwasResolveMethod(list(r1 = tw), "bogus"), - "not present in TwasWeights" - ) -}) - -test_that(".ctwasResolveMethod: defaults to ensemble when present among multiple", { - mkTw <- function(m) { - e <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.1, 0.2, 0.3) - ) - TwasWeights( - studyName = "Q1", - context = "c1", - trait = "t1", - method = m, - entry = list(e), - ldReference = .ctp_makeHandle() - ) - } - # Build a multi-method TwasWeights by stitching two methods together. - tw <- TwasWeights( - studyName = c("Q1", "Q1"), - context = c("c1", "c1"), - trait = c("t1", "t1"), - method = c("mrash", "ensemble"), - entry = list( - twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.1, 0.2, 0.3) - ), - twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.4, 0.5, 0.6) - ) - ), - ldReference = .ctp_makeHandle() - ) - expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw)), "ensemble") -}) - -test_that(".ctwasResolveMethod: single method auto-picked when only one available", { - e <- twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.1, 0.2, 0.3) - ) - tw <- TwasWeights( - studyName = "Q1", - context = "c1", - trait = "t1", - method = "mrash", - entry = list(e), - ldReference = .ctp_makeHandle() - ) - expect_equal(pecotmr:::.ctwasResolveMethod(list(r1 = tw)), "mrash") -}) - -test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method errors", { - tw <- TwasWeights( - studyName = c("Q1", "Q1"), - context = c("c1", "c1"), - trait = c("t1", "t1"), - method = c("mrash", "susie"), - entry = list( - twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.1, 0.2, 0.3) - ), - twasWeightsRow( - variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), - weights = c(0.4, 0.5, 0.6) - ) - ), - ldReference = .ctp_makeHandle() - ) + # One method present is still not a default: only "ensemble" is. expect_error( pecotmr:::.ctwasResolveMethod(list(r1 = tw)), - "Supply a `method` argument" + str_c( + "pass `method` to choose the weights\\. These TwasWeights carry ", + "no 'ensemble' weights to default to \\(available: mrash\\)" + ) ) }) # --------------------------------------------------------------------------- -# .ctwasResolveMethods (plural) — the pipeline's fan-out resolver +# .ctwasResolveMethod on the shapes a pipeline hands it # --------------------------------------------------------------------------- .ctp_multiMethodTw <- function(methods = c("mrash", "susie")) { TwasWeights( @@ -956,7 +905,7 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er trait = rep("t1", length(methods)), method = methods, entry = map(methods, function(m) { - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) ) @@ -965,41 +914,40 @@ test_that(".ctwasResolveMethod: multi-method + no ensemble + no caller method er ) } -test_that(".ctwasResolveMethods: unspecified + multiple + no ensemble -> ALL methods", { - tw <- .ctp_multiMethodTw(c("mrash", "susie")) - expect_setequal( - pecotmr:::.ctwasResolveMethods(list(r1 = tw)), - c("mrash", "susie") - ) -}) - -test_that(".ctwasResolveMethods: ensemble wins, single auto-picks, explicit restricts", { +test_that(".ctwasResolveMethod reads one flat source or a list of them", { + # A flat TwasWeights, and a pre-bucketed list with an empty block. expect_equal( - pecotmr:::.ctwasResolveMethods( - list(r1 = .ctp_multiMethodTw(c("mrash", "ensemble"))) - ), + pecotmr:::.ctwasResolveMethod(.ctp_multiMethodTw(c( + "mrash", + "ensemble" + ))), "ensemble" ) expect_equal( - pecotmr:::.ctwasResolveMethods( - list(r1 = .ctp_multiMethodTw("mrash")) - ), - "mrash" - ) - expect_equal( - pecotmr:::.ctwasResolveMethods( + pecotmr:::.ctwasResolveMethod( list(r1 = .ctp_multiMethodTw(c("mrash", "susie")), r2 = NULL), method = "susie" ), "susie" ) expect_error( - pecotmr:::.ctwasResolveMethods( + pecotmr:::.ctwasResolveMethod( list(r1 = .ctp_multiMethodTw("mrash")), method = "lasso" ), - "not present" + "method 'lasso' not present in the weight sources" + ) +}) + +test_that(".ctwasResolveMethod: a fine-mapping weight source has no default", { + # A fine-mapping result's weights come from one of its methods, and none + # of them is an "ensemble" -- even one named that way would be a guess. + src <- .ctp_makeFmrWeightSource() + expect_error( + pecotmr:::.ctwasResolveMethod(src), + "one of its fine-mapping methods \\(available: susie\\)" ) + expect_equal(pecotmr:::.ctwasResolveMethod(src, "susie"), "susie") }) # --------------------------------------------------------------------------- @@ -1021,34 +969,58 @@ test_that(".ctwasGwasStudy: unique study, errors on mixed studies", { # --------------------------------------------------------------------------- # Phase 5: internal LD-block placement (by start(region) == cTWAS p0 rule) # --------------------------------------------------------------------------- -test_that(".ctwasPlaceByAnchor: homes each gene by start(region), half-open, chr-agnostic", { +# Three LD blocks split from one GWAS by their windows, as cTWAS takes them: +# one single-row slice per block, named by its blockId. The variants sit well +# inside each window (chr1:500, chr1:1500, chr22:800). +.ctp_windowGrid <- function() { + gr <- GenomicRanges::GRanges( + c("chr1", "chr1", "chr22"), + IRanges::IRanges(start = c(500L, 1500L, 800L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = c("chr1:500:G:A", "chr1:1500:G:A", "chr22:800:G:A"), + A1 = "A", + A2 = "G", + Z = 0, + N = 1000L + ) + blocks <- GenomicRanges::GRanges( + c("chr1:1-1000", "chr1:1001-2000", "chr22:1-1000") + ) + names(blocks) <- c("b1", "b2", "b3") + pecotmr:::.ctwasGwasByBlock(GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + region = blocks + )) +} + +test_that(".ctwasPlaceByAnchor homes genes by start(region)", { region <- GenomicRanges::GRanges( - c("chr1", "chr1", "22", "chr2"), + c("chr1", "chr1", "chr22", "chr2"), IRanges::IRanges( start = c(500, 1500, 800, 100), end = c(600, 1600, 900, 200) ) ) - grid <- setNames( - vector("list", 3), - c("chr1_1_1000", "chr1_1000_2000", "chr22_1_1000") - ) - home <- pecotmr:::.ctwasPlaceByAnchor(region, grid) - # chr1:500 -> [1,1000); chr1:1500 -> [1000,2000); "22":800 -> chr22 block - # (chr prefix normalized); chr2 -> no block -> NA. - expect_equal(home, c("chr1_1_1000", "chr1_1000_2000", "chr22_1_1000", NA)) + home <- pecotmr:::.ctwasPlaceByAnchor(region, .ctp_windowGrid()) + # chr22:800 -> the chr22 block; chr2 has no block -> NA. + expect_equal(home, c("b1", "b2", "b3", NA)) }) -test_that(".ctwasPlaceByAnchor: block interval is half-open [start, stop)", { +test_that(".ctwasPlaceByAnchor: a block holds its whole window", { + # chr1:900 lies between block 1's variant (500) and block 2's (1500): the + # window, not the variants, decides. The blocks' names are only names, and + # the last base of a window (1000) is its own, the next (1001) the next + # block's. region <- GenomicRanges::GRanges( "chr1", - IRanges::IRanges(start = c(1000, 999), end = c(1000, 999)) + IRanges::IRanges(start = c(900, 1000, 1001), width = 1) ) - grid <- setNames(vector("list", 2), c("chr1_1_1000", "chr1_1000_2000")) - # start==1000 falls in the SECOND block (>= 1000), 999 in the first. expect_equal( - pecotmr:::.ctwasPlaceByAnchor(region, grid), - c("chr1_1000_2000", "chr1_1_1000") + pecotmr:::.ctwasPlaceByAnchor(region, .ctp_windowGrid()), + c("b1", "b1", "b2") ) }) @@ -1067,7 +1039,7 @@ test_that(".ctwasIsPreBucketed / .ctwasCombineWeightSources: dispatch flat vs pr test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks", { mkE <- function() { - twasWeightsRow( + TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) @@ -1093,7 +1065,7 @@ test_that(".ctwasBucketWeights: places a flat 2-gene source into its home blocks 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(ldReference(bucketed[["block1"]]))) + expect_length(ldReference(bucketed[["block1"]]), 1L) }) test_that(".ctwasBucketWeights: errors when source lacks traitPos", { @@ -1280,11 +1252,11 @@ test_that(".ctwasFilterMethod: subsets rows to the requested method", { trait = c("t1", "t1"), method = c("mrash", "susie"), entry = list( - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.1, 0.2, 0.3) ), - twasWeightsRow( + TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), weights = c(0.4, 0.5, 0.6) ) @@ -1309,46 +1281,40 @@ test_that(".ctwasFilterMethod: subsets rows to the requested method", { list(R = R, snpInfo = snpInfo, variance = variance) } -test_that(".ctwasBuildWeights: scales non-standardized weights by sqrt(variance)", { +test_that(".ctwasBuildWeights: only raw weights are scaled by sqrt(variance)", { panel <- .ctp_makeLdPanel() # Replace the default unit variance with non-trivial values; raw # weights should be multiplied by sqrt(variance) before reaching the - # final wgt matrix. + # final wgt matrix, and standardized weights bypass the scaling. panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) ids5 <- map_chr(1:5, .ctp_snpId) rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) - tw <- TwasWeights( - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(twasWeightsRow(variantIds = ids5, weights = rawW)), - ldReference = .ctp_makeHandle() - ) - wl <- pecotmr:::.ctwasBuildWeights(tw, panel) - expected <- unname(rawW * sqrt(panel$variance[ids5])) - expect_equal(as.numeric(wl[[1L]]$wgt), expected, tolerance = 1e-12) -}) - -test_that(".ctwasBuildWeights: standardized weights bypass variance scaling", { - panel <- .ctp_makeLdPanel() - panel$variance <- setNames(c(0.5, 1, 2, 4, 8, 16), panel$snpInfo$id) - ids5 <- map_chr(1:5, .ctp_snpId) - rawW <- c(0.1, 0.2, 0.3, 0.4, 0.5) - tw <- TwasWeights( - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(twasWeightsRow( - variantIds = ids5, - weights = rawW, - weightStandardized = TRUE - )), - ldReference = .ctp_makeHandle() - ) - wl <- pecotmr:::.ctwasBuildWeights(tw, panel) - expect_equal(as.numeric(wl[[1L]]$wgt), rawW, tolerance = 1e-12) + for (standardized in c(FALSE, TRUE)) { + tw <- TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(TwasWeightsRow( + variantIds = ids5, + weights = rawW, + weightStandardized = standardized + )), + ldReference = .ctp_makeHandle() + ) + wl <- pecotmr:::.ctwasBuildWeights(tw, panel) + expected <- if (standardized) { + rawW + } else { + unname(rawW * sqrt(panel$variance[ids5])) + } + expect_equal( + as.numeric(wl[[1L]]$wgt), + expected, + tolerance = 1e-12, + info = str_c("weightStandardized = ", standardized) + ) + } }) # Build an LD-panel fixture with realistic chr:pos:A2:A1 variant IDs so @@ -1430,54 +1396,6 @@ test_that(".ctwasIsSusieFit: recognizes the susie intermediate shape", { ))) }) -test_that(".ctwasRenormalizeSusieWeights: alpha renorm + colSums", { - # Original fit covers 4 variants; drop variant 4, renormalize over {1,2,3}. - origVids <- sprintf("chr1:%d:A:G", 100L * (1:4)) - origW <- c(0.1, 0.2, 0.3, 0.4) - # Toy lbf_variable: 2 effects, 4 variants. Constructed so the kept - # subset yields easily-predictable softmax weights. - lbf <- rbind( - c(0, 0, 0, 100), # effect 1: only v4 has signal - c(10, 0, -10, 0) - ) # effect 2: v1 dominates - mu <- matrix(c(1, 2, 3, 4, 1, 2, 3, 4), nrow = 2, byrow = TRUE) - xCol <- rep(1, 4) - fits <- list( - alpha = lbfToAlpha(lbf), - mu = mu, - X_column_scale_factors = xCol - ) - out <- pecotmr:::.ctwasRenormalizeSusieWeights( - fits, - origVids = origVids, - origW = origW, - keptIdx = c(1L, 2L, 3L), - harmonizedW = origW[1:3] - ) - # Effect 1 lbf over {v1,v2,v3} = c(0,0,0) -> uniform alpha = 1/3 - # Effect 2 lbf over {v1,v2,v3} = c(10,0,-10) -> v1 ≈ 1 - # weight[v1] = (1/3)*1 + ~1*1 = ~1.33 - expect_equal(length(out), 3L) - expect_true(out[[1L]] > out[[2L]] && out[[1L]] > out[[3L]]) -}) - -test_that(".ctwasRenormalizeSusieWeights: returns NULL on fit/entry dimension mismatch", { - fits <- list( - alpha = matrix(1 / 5, 2, 5), - mu = matrix(0, 2, 5), - X_column_scale_factors = rep(1, 5) - ) - out <- pecotmr:::.ctwasRenormalizeSusieWeights( - fits, - # entry says 3, fit covers 5 -> mismatch - origVids = sprintf("chr1:%d:A:G", 100L * (1:3)), - origW = rep(0.1, 3), - keptIdx = 1:3, - harmonizedW = rep(0.1, 3) - ) - expect_null(out) -}) - test_that(".ctwasRenormalizeSusieWeights: signFlip carries over to mu", { # All variants kept; harmonized weights have opposite sign on v2. origVids <- sprintf("chr1:%d:A:G", 100L * (1:3)) @@ -1550,56 +1468,20 @@ test_that(".ctwasRenormalizeSusieWeights: honours a non-uniform prior", { ) }) -test_that(".ctwasRenormalizeSusieWeights: skips Omega-weighted susieInf fits", { - # coef.susie for susieInf / susieAsh is colSums(alpha * mu)/scale + - # theta/scale. Recomputing from alpha and mu alone would drop theta, so - # these fits fall back to the plain subset-w-and-R path instead. - origVids <- sprintf("chr1:%d:A:G", 100L * (1:4)) - origW <- c(0.1, 0.2, 0.3, 0.4) - base <- list( - alpha = lbfToAlpha(rbind(c(2, 0, -2, 0), c(0, 2, 0, -2))), - mu = rbind(c(1, 2, 3, 4), c(1, 2, 3, 4)), - X_column_scale_factors = rep(1, 4) - ) - args <- list( - origVids = origVids, - origW = origW, - keptIdx = c(1L, 2L, 3L), - harmonizedW = origW[1:3] - ) - expect_type( - exec(pecotmr:::.ctwasRenormalizeSusieWeights, !!!c(list(base), args)), - "double" - ) - withTheta <- c(base, list(theta = rep(0.1, 4))) - expect_null(exec( - pecotmr:::.ctwasRenormalizeSusieWeights, - !!!c(list(withTheta), args) - )) - withOmega <- c(base, list(omega_weights = rep(1, 4))) - expect_null(exec( - pecotmr:::.ctwasRenormalizeSusieWeights, - !!!c(list(withOmega), args) - )) -}) - test_that(".ctwasSnpInfoForGwasBlock: restricts panel snpInfo to block GWAS variants", { - ss <- .ctp_makeGwasSumstats() + # Block 1's GWAS rows (variants 1..6) against the whole 12-variant panel. + ss <- .ctp_makeGwasSumstats(blockIds = "block1") panelInfo <- data.frame( chrom = 1L, - id = map_chr(1:6, .ctp_snpId), # whole panel - pos = seq(100L, by = 100L, length.out = 6L), + id = map_chr(1:12, .ctp_snpId), # whole panel + pos = seq(100L, by = 100L, length.out = 12L), alt = "A", ref = "G", stringsAsFactors = FALSE ) blockInfo <- pecotmr:::.ctwasSnpInfoForGwasBlock(ss, panelInfo) - # Restricted to the variant IDs on the GwasSumStats entry. - expect_true(all( - blockInfo$id %in% - as.character(S4Vectors::mcols(ss[[1L]])$SNP) - )) - expect_true(nrow(blockInfo) <= nrow(panelInfo)) + # Restricted to the variant IDs on the GwasSumStats entry, in panel order. + expect_equal(blockInfo$id, map_chr(1:6, .ctp_snpId)) }) test_that(".ctwasBuildWeights: keys per-tuple weights, adds gene metadata", { @@ -1635,7 +1517,7 @@ test_that(".ctwasBuildWeights: drops variants not present in the LD panel", { context = "c1", trait = "t1", method = "susie", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = c(ids3, missing), weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), @@ -1660,7 +1542,7 @@ test_that(".ctwasBuildWeights: intersects with gwasSnpIds when supplied", { context = "c1", trait = "t1", method = "susie", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = ids5, weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), @@ -1771,9 +1653,9 @@ test_that(".ctwasGlobalPanelInfo: NULL when the collection has no sketch", { entry = list(.ctp_blockVariants(1L)), genome = "hg19", blockId = "block1", - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) - expect_null(ldReference(gs)) + expect_identical(ldReference(gs), list()) # .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)) @@ -1942,7 +1824,8 @@ test_that("assembleCtwasInputs: assembles the documented input shape for ctwas", ) inputs <- assembleCtwasInputs( gwasSumStats = inp$gwasSumStats, - twasWeights = inp$twasWeights + twasWeights = inp$twasWeights, + method = "susie" ) # Two regions, two LD_map rows. expect_equal(nrow(inputs$region_info), 2L) @@ -1977,7 +1860,8 @@ test_that("assembleCtwasInputs: forwards a twasZ argument as z_gene", { inputs <- assembleCtwasInputs( gwasSumStats = inp$gwasSumStats, twasWeights = inp$twasWeights, - twasZ = twasZ + twasZ = twasZ, + method = "susie" ) expect_equal(inputs$z_gene$id, "Q1|c1|t1|susie") }) @@ -2044,7 +1928,8 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and ) out <- ctwasPipeline( gwasSumStats = inp$gwasSumStats, - twasWeights = inp$twasWeights + twasWeights = inp$twasWeights, + method = "susie" ) # Each ctwas step was invoked exactly once. expect_true(length(capturedAssemble) > 0L) @@ -2057,7 +1942,8 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and expect_equal(unname(capturedScreen$group_prior), c(0.1, 0.0001)) # finemap consumes screen's screened_region_data. expect_named(capturedFinemap$region_data, "block1") - # Output is a CtwasResult: one (gwasStudy, study, context, method) row. + # Output is a CtwasResult: one row per (run, region), and this run's + # genes, placed without a region_id, share one chromosome. expect_s4_class(out, "CtwasResult") expect_equal(nrow(out), 1L) expect_equal(methodNames(out), "susie") @@ -2065,21 +1951,23 @@ test_that("ctwasPipeline: dispatches assemble → est → screen → finemap and expect_equal(contexts(out), "c1") expect_equal(as.character(out$gwasStudy), "G1") # The run's jointly-estimated param is carried on the row. - expect_equal( - unname(ctwasGroupPriors(out$entry[[1L]])$group_prior), - c(0.1, 0.0001) - ) + expect_equal(unname(out$groupPriors[[1L]]$group_prior), c(0.1, 0.0001)) # ctwasPosteriors aggregates the per-gene rows, tagged with run identity. fm <- ctwasPosteriors(out) - expect_equal(nrow(fm), 2L) + expect_s4_class(fm, "GRanges") + expect_equal(length(fm), 2L) expect_true(all( - c("gwasStudy", "study", "context", "method", "susie_pip") %in% names(fm) + c("gwasStudy", "study", "context", "method", "susie_pip") %in% + names(S4Vectors::mcols(fm)) )) expect_setequal(fm$id, c("block1|Q1|c1|t1|susie", "block2|Q1|c1|t1|susie")) # susieAlpha aggregates the fuller per-effect table, likewise tagged. sa <- susieAlpha(out) - expect_equal(nrow(sa), 2L) - expect_true(all(c("gwasStudy", "context", "susie_alpha") %in% names(sa))) + expect_equal(length(sa), 2L) + expect_true(all( + c("gwasStudy", "context", "susie_alpha") %in% + names(S4Vectors::mcols(sa)) + )) }) test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row", { @@ -2124,7 +2012,12 @@ test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) - out <- ctwasPipeline(inp$gwasSumStats, inp$twasWeights, keepSnps = TRUE) + out <- ctwasPipeline( + inp$gwasSumStats, + inp$twasWeights, + keepSnps = TRUE, + method = "susie" + ) # A gene (c1) row plus the dedicated SNP row. expect_equal(nrow(out), 2L) expect_setequal(contexts(out), c("c1", "SNP")) @@ -2155,7 +2048,11 @@ test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row ), z_snp = data.frame(id = "chr1:100:G:A", z = 1.0), z_gene = data.frame(id = "block1|Q1|c1|t1|susie", z = 2.0), - weights = setNames(list(list(wgt = 1)), "block1|Q1|c1|t1|susie"), + # Placed by chrom / p0 / p1, as ctwas's own weights are. + weights = setNames( + list(list(wgt = 1, chrom = 1, p0 = 100L, p1 = 100L)), + "block1|Q1|c1|t1|susie" + ), snp_map = list(block1 = data.frame(id = "chr1:100:G:A")), param = list( group_prior = c(c1 = 0.1, SNP = 1e-4), @@ -2194,30 +2091,6 @@ test_that("ctwasPipeline: keepSnps retains the SNP background as a dedicated row ) } -test_that("mergeCtwasBoundaryRegions: LD path splices updated_* back + merge_res", { - skip_if_not_installed("ctwas") - captured <- NULL - local_mocked_bindings( - postprocess_region_merging = function(...) { - captured <<- list(...) - .ctp_mergeReturn() - }, - .package = "ctwas" - ) - out <- mergeCtwasBoundaryRegions( - .ctp_finemapResult(hasLd = TRUE), - pipThresh = 0.5 - ) - # LD path passed the loader closures + pip_thresh through. - expect_equal(captured$pip_thresh, 0.5) - expect_true(is.function(captured$LD_loader_fun)) - # updated_* spliced onto the result; merge_res carries the full postprocess out. - expect_equal(out$finemap_res$susie_pip, 0.99) - expect_equal(out$susie_alpha_res$susie_alpha, 0.99) - expect_equal(out$region_info$region_id, "block1_merged") - expect_true(!is.null(out$merge_res)) -}) - test_that("mergeCtwasBoundaryRegions passes no unnamed argument to ctwas", { skip_if_not_installed("ctwas") # Regression: methodArgs was merged with c(), which appends a MethodOptions @@ -2265,17 +2138,6 @@ test_that("mergeCtwasBoundaryRegions: no-LD path uses postprocess_region_merging expect_equal(out$finemap_res$susie_pip, 0.99) }) -test_that("mergeCtwasBoundaryRegions: empty first-pass finemap returns unchanged", { - skip_if_not_installed("ctwas") - fmr <- .ctp_finemapResult() - fmr$finemap_res <- fmr$finemap_res[0, ] - expect_message( - out <- mergeCtwasBoundaryRegions(fmr), - "no first-pass finemap" - ) - expect_null(out$merge_res) -}) - test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into CtwasResult", { skip_if_not_installed("ctwas") inp <- .ctp_makeMultiBlockInputs() @@ -2335,7 +2197,8 @@ test_that("ctwasPipeline: mergeBoundary = TRUE re-fine-maps and flows into Ctwas out <- ctwasPipeline( inp$gwasSumStats, inp$twasWeights, - boundaryMergeParam = BoundaryMergeParam(enabled = TRUE) + boundaryMergeParam = BoundaryMergeParam(enabled = TRUE), + method = "susie" ) expect_true(merged) # merging ran expect_s4_class(out, "CtwasResult") @@ -2422,10 +2285,17 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d extractBlockGenotypes = .ctp_mockExtractor(), .package = "pecotmr" ) + # Assembled once; the two estimation calls below differ only in the + # fallback setting. + inputs <- assembleCtwasInputs( + inp$gwasSumStats, + inp$twasWeights, + method = "susie" + ) # Without fallback: the NaN error propagates. expect_error( estCtwasGroupPriors( - assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), + inputs, ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = FALSE) ), "contains NAs" @@ -2435,7 +2305,7 @@ test_that("estCtwasGroupPriors: fallbackToPrefit recovers from accurate-EM NaN d # est_param), so the mocked SNP prior 1e-4 emerges as 1e-4 * thin # (default thin = 0.1) → 1e-5. The group_prior_var is not thinned. est <- estCtwasGroupPriors( - assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), + inputs, ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = TRUE) ) expect_equal(unname(est$param$group_prior), c(0.05, 1e-5)) @@ -2478,7 +2348,11 @@ test_that("estCtwasGroupPriors fallback drops degenerate regions before fit_EM", .package = "pecotmr" ) est <- estCtwasGroupPriors( - assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights), + assembleCtwasInputs( + inp$gwasSumStats, + inp$twasWeights, + method = "susie" + ), ctwasPriorParam = CtwasPriorParam(fallbackToPrefit = TRUE) ) # only the qualifying region reached fit_EM; the degenerate region was filtered @@ -2511,7 +2385,7 @@ test_that("(real ctwas) prefit fallback skips a degenerate region fit_EM would r niter = 3L, groupPriorVarStructure = "shared_all", thin = 1, - numThreads = 1L + threads = 1L ), "EM did not converge in 3 iterations" ) @@ -2554,7 +2428,11 @@ test_that("estCtwasGroupPriors / screenCtwasRegions / finemapCtwasRegions can be .package = "pecotmr" ) # Step 1 - inputs <- assembleCtwasInputs(inp$gwasSumStats, inp$twasWeights) + inputs <- assembleCtwasInputs( + inp$gwasSumStats, + inp$twasWeights, + method = "susie" + ) expect_true("region_info" %in% names(inputs)) expect_true("LD_loader_fun" %in% names(inputs)) # Step 2 @@ -2611,11 +2489,11 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # with no genes in it, so a real partition needs a gene on both sides -- # the previous per-region list dodged this by putting the SAME GWAS block # and the SAME gene under two region ids. - geneOne <- twasWeightsRow( + geneOne <- TwasWeightsRow( variantIds = .ctp_panelSnpInfo(gh)$SNP[1:5], weights = c(0.1, -0.2, 0.05, 0.0, 0.3) ) - geneTwo <- twasWeightsRow( + geneTwo <- TwasWeightsRow( variantIds = .ctp_panelSnpInfo(gh)$SNP[9:13], weights = c(0.2, 0.1, -0.15, 0.05, 0.0) ) @@ -2658,8 +2536,8 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", entry = list(unlist(gss)), genome = unique(unname(GenomeInfoDb::genome(gss))), ldReference = ldReference(gss), - qcInfo = qcInfo(gss), - ldBlocks = twoBlocks + qcOptions = qcOptions(gss), + region = twoBlocks ) res <- suppressMessages(suppressWarnings( ctwasPipeline( @@ -2676,7 +2554,8 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", min_group_size = 1L, min_p_single_effect = 0 ) - ) + ), + method = "susie" ) )) @@ -2691,9 +2570,10 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", # The gene we passed in was fine-mapped and shows up in the aggregated # finemap table, tagged with the run identity. fm <- ctwasPosteriors(res) - expect_true(!is.null(fm) && nrow(fm) > 0L) + expect_gt(length(fm), 0L) expect_true(all( - c("gwasStudy", "study", "context", "method", "susie_pip") %in% names(fm) + c("gwasStudy", "study", "context", "method", "susie_pip") %in% + names(S4Vectors::mcols(fm)) )) # Either gene may survive ctwas's region screen; what matters here is that # a fine-mapped gene carries the full run identity in its id. @@ -2707,12 +2587,15 @@ test_that("ctwasPipeline: real-engine end-to-end on the bundled example panel", expect_true(all(fm$context == "brain")) # The fuller per-effect table is retained and reconstructable. sa <- susieAlpha(res) - expect_true(!is.null(sa) && nrow(sa) > 0L) - expect_true(all(c("susie_pip", "susie_alpha", "region_id") %in% names(sa))) + expect_gt(length(sa), 0L) + expect_true(all( + c("susie_pip", "susie_alpha", "region_id") %in% + names(S4Vectors::mcols(sa)) + )) }) # =========================================================================== -# .ctwasFilterVariants — ported from R/ctwasWrapper.R::trimCtwasVariants +# .ctwasFilterVariants # =========================================================================== # The filter has four knobs: # 1. twasWeightCutoff — drop |w| < cutoff @@ -2813,53 +2696,45 @@ test_that(".ctwasFilterVariants: returns NULL when no variants survive", { expect_null(out) }) -test_that(".ctwasBuildWeights: maxNumVariants caps the per-gene weight matrix", { +test_that(".ctwasBuildWeights: the variant cap and weight cutoff apply", { data(qtlDatasetExample) - qd <- qtlDatasetExample - gh <- pecotmr:::.qtlGenotypeSe(qd) + gh <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) vids <- .ctp_panelSnpInfo(gh)$SNP[1:5] - ent <- twasWeightsRow( - variantIds = vids, - weights = c(0.1, -0.2, 0.05, 0.3, 0.15) - ) - tw <- TwasWeights( - studyName = "study1", - context = "brain", - trait = "ENSG_example", - method = "susie", - entry = list(ent), - ldReference = gh - ) ldPanel <- .ctp_fullPanel(gh) - wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, maxNumVariants = 3L) - expect_equal(wl[[1L]]$n_wgt, 3L) - expect_equal(nrow(wl[[1L]]$wgt), 3L) - # Top 3 by |w| from c(0.1, -0.2, 0.05, 0.3, 0.15): 0.3, -0.2, 0.15 - expect_setequal(rownames(wl[[1L]]$wgt), vids[c(4L, 2L, 5L)]) -}) - -test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { - data(qtlDatasetExample) - qd <- qtlDatasetExample - 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 - weights = c(0.005, 0.2, 0.001, 0.3, 0.1) - ) - tw <- TwasWeights( - studyName = "study1", - context = "brain", - trait = "ENSG_example", - method = "susie", - entry = list(ent), - ldReference = gh + # Each case: the weights, the filter setting, and the variants kept. + cases <- list( + # Top 3 by |w| from c(0.1, -0.2, 0.05, 0.3, 0.15): 0.3, -0.2, 0.15 + maxNumVariants = list( + c(0.1, -0.2, 0.05, 0.3, 0.15), + list(maxNumVariants = 3L), + c(4L, 2L, 5L) + ), + # v1 (0.005) and v3 (0.001) fall below the 0.01 cutoff + twasWeightCutoff = list( + c(0.005, 0.2, 0.001, 0.3, 0.1), + list(twasWeightCutoff = 0.01), + c(2L, 4L, 5L) + ) ) - ldPanel <- .ctp_fullPanel(gh) - wl <- pecotmr:::.ctwasBuildWeights(tw, ldPanel, twasWeightCutoff = 0.01) - expect_equal(wl[[1L]]$n_wgt, 3L) - expect_setequal(rownames(wl[[1L]]$wgt), vids[c(2L, 4L, 5L)]) + for (nm in names(cases)) { + cs <- cases[[nm]] + tw <- TwasWeights( + studyName = "study1", + context = "brain", + trait = "ENSG_example", + method = "susie", + entry = list(TwasWeightsRow(variantIds = vids, weights = cs[[1L]])), + ldReference = gh + ) + wl <- exec(pecotmr:::.ctwasBuildWeights, tw, ldPanel, !!!cs[[2L]]) + expect_equal(wl[[1L]]$n_wgt, 3L, info = nm) + expect_equal(nrow(wl[[1L]]$wgt), 3L, info = nm) + expect_equal( + sort(rownames(wl[[1L]]$wgt)), + sort(vids[cs[[3L]]]), + info = nm + ) + } }) # =========================================================================== @@ -2867,13 +2742,18 @@ test_that(".ctwasBuildWeights: twasWeightCutoff drops low-magnitude variants", { # =========================================================================== test_that("mergeCtwasBoundaryRegions: no first-pass finemap_res returns unchanged", { + skip_if_not_installed("ctwas") fmr <- list(finemap_res = NULL, region_data = "rd") - expect_identical(mergeCtwasBoundaryRegions(fmr), fmr) + expect_message( + expect_identical(mergeCtwasBoundaryRegions(fmr), fmr), + "no first-pass finemap" + ) fmr0 <- list(finemap_res = data.frame()[0, ], region_data = "rd") - expect_identical(mergeCtwasBoundaryRegions(fmr0), fmr0) + expect_identical(suppressMessages(mergeCtwasBoundaryRegions(fmr0)), fmr0) }) test_that("mergeCtwasBoundaryRegions: LD path forwards carried state + splices updated_*", { + skip_if_not_installed("ctwas") captured <- NULL local_mocked_bindings( postprocess_region_merging = function(...) { @@ -2909,6 +2789,7 @@ test_that("mergeCtwasBoundaryRegions: LD path forwards carried state + splices u expect_true(all( c("LD_map", "LD_loader_fun", "snpinfo_loader_fun") %in% names(captured) )) + expect_true(is.function(captured$LD_loader_fun)) expect_equal(captured$pip_thresh, 0.5) expect_equal(captured$maxSNP, 100) expect_identical(captured$region_data, "rd") @@ -2923,36 +2804,6 @@ test_that("mergeCtwasBoundaryRegions: LD path forwards carried state + splices u expect_identical(out$merge_res$selected_boundary_genes$id, "g") }) -test_that("mergeCtwasBoundaryRegions: no-LD path used when LD loaders are absent", { - called <- NULL - local_mocked_bindings( - postprocess_region_merging_noLD = function(...) { - called <<- "noLD" - list( - updated_finemap_res = data.frame(id = "g"), - updated_susie_alpha_res = NULL - ) - }, - .package = "ctwas" - ) - fmr <- list( - finemap_res = data.frame(id = "g", type = "gene", susie_pip = 0.6), - susie_alpha_res = NULL, - region_data = "rd", - region_info = "ri", - z_snp = "zs", - z_gene = data.frame(id = "g"), - weights = "w", - snp_map = "sm", - LD_map = NULL, - LD_loader_fun = NULL, - snpinfo_loader_fun = NULL, - param = list(group_prior = 0.1, group_prior_var = 5) - ) - out <- mergeCtwasBoundaryRegions(fmr) - expect_equal(called, "noLD") -}) - # =========================================================================== # assembleCtwasInputs: remaining input-validation branches # --------------------------------------------------------------------------- @@ -2961,19 +2812,6 @@ test_that("mergeCtwasBoundaryRegions: no-LD path used when LD loaders are absent # guard would surface a different error). # =========================================================================== -test_that("assembleCtwasInputs: rejects an unnamed gwasSumStats list", { - skip_if_not_installed("ctwas") - ss <- .ctp_makeGwasSumstats() - tw <- .ctp_makeTwasWeights() - expect_error( - assembleCtwasInputs( - gwasSumStats = list(ss, ss), # unnamed - twasWeights = list(block1 = tw) - ), - "must be a GwasSumStats whose elements are LD blocks" - ) -}) - test_that("assembleCtwasInputs: an unnamed twasWeights list is a FLAT source (needs region)", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() @@ -2983,7 +2821,8 @@ test_that("assembleCtwasInputs: an unnamed twasWeights list is a FLAT source (ne expect_error( assembleCtwasInputs( gwasSumStats = ss, - twasWeights = list(tw) + twasWeights = list(tw), + method = "susie" ), # unnamed -> flat "no `traitPos` provenance" ) @@ -2995,7 +2834,8 @@ test_that("assembleCtwasInputs: rejects a non-GwasSumStats gwas input", { expect_error( assembleCtwasInputs( gwasSumStats = "not a GwasSumStats", - twasWeights = list(block1 = tw) + twasWeights = list(block1 = tw), + method = "susie" ), "must be a GwasSumStats whose elements are LD blocks" ) @@ -3007,13 +2847,14 @@ test_that("assembleCtwasInputs: rejects a weight source that is neither TwasWeig expect_error( assembleCtwasInputs( gwasSumStats = ss, - twasWeights = list(block1 = "not a weight source") + twasWeights = list(block1 = "not a weight source"), + method = "susie" ), "must be a TwasWeights or QtlFineMappingResult" ) }) -test_that("assembleCtwasInputs: rejects a non-FineMappingResultBase fineMappingResult", { +test_that("assembleCtwasInputs: the rescue source is a QtlFineMappingResult", { skip_if_not_installed("ctwas") ss <- .ctp_makeGwasSumstats() tw <- .ctp_makeTwasWeights() @@ -3021,9 +2862,27 @@ test_that("assembleCtwasInputs: rejects a non-FineMappingResultBase fineMappingR assembleCtwasInputs( gwasSumStats = ss, twasWeights = list(block1 = tw), - fineMappingResult = "not a fine-mapping result" + fineMappingResult = "not a fine-mapping result", + method = "susie" ), - "must be a FineMappingResultBase" + "must be a QtlFineMappingResult" + ) + # A GWAS result is keyed by a study and method no gene shares, so it can + # only ever have matched a gene by a coincidence of names. + tl <- data.frame(variant_id = "chr1:100:A:G", pip = 0.5) + gwasFmr <- GwasFineMappingResult( + studyName = "Q1", + method = "susie", + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) + ) + expect_error( + assembleCtwasInputs( + gwasSumStats = ss, + twasWeights = list(block1 = tw), + fineMappingResult = gwasFmr, + method = "susie" + ), + "the genes' own fine-mapping" ) }) @@ -3037,7 +2896,7 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv context = "c1", trait = "t1", method = m, - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = ids5, weights = c(0.1, 0.2, 0.3, 0.4, 0.5) )), @@ -3049,8 +2908,7 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv .package = "pecotmr" ) # Resolved method is "ensemble" (present in block1); block2 carries only - # "mrash", so .ctwasFilterMethod returns NULL and the block is skipped - # in the second pass (the `if (is.null(twMethod)) next` branch). + # "mrash", so .ctwasFilterMethod returns NULL and the block is skipped. inputs <- assembleCtwasInputs( gwasSumStats = ss, twasWeights = list(block1 = mkTw("ensemble"), block2 = mkTw("mrash")) @@ -3061,20 +2919,16 @@ test_that("assembleCtwasInputs: skips a block whose TwasWeights lacks the resolv }) # =========================================================================== -# .ctwasResolveMethod / .ctwasFilterMethod edge branches +# .ctwasFilterMethod edge branch # =========================================================================== -test_that(".ctwasResolveMethod: errors when no method entries exist", { - expect_error(pecotmr:::.ctwasResolveMethod(list()), "no method entries") -}) - test_that(".ctwasFilterMethod: returns NULL when no row matches the method", { tw <- .ctp_makeTwasWeights() # method == "susie" expect_null(pecotmr:::.ctwasFilterMethod(tw, "mrash")) }) # =========================================================================== -# .ctwasHarmonizeWeights / .ctwasRenormalizeSusieWeights early NULL returns +# .ctwasHarmonizeWeights early NULL returns # =========================================================================== test_that(".ctwasHarmonizeWeights: returns NULL when there is nothing to parse", { @@ -3115,38 +2969,10 @@ test_that(".ctwasHarmonizeWeights: returns NULL when harmonizeAlleles fails", { )) }) -test_that(".ctwasRenormalizeSusieWeights: returns NULL when fit components are NULL", { - fits <- list( - lbf_variable = NULL, - mu = matrix(0, 2, 3), - X_column_scale_factors = rep(1, 3) - ) - expect_null(pecotmr:::.ctwasRenormalizeSusieWeights( - fits, - origVids = sprintf("chr1:%d:A:G", 100L * (1:3)), - origW = rep(0.1, 3), - keptIdx = 1:3, - harmonizedW = rep(0.1, 3) - )) -}) - # =========================================================================== # .ctwasBuildWeights: per-gene skip branches + variance / renorm paths # =========================================================================== -test_that("TwasWeightsRow: rejects mismatched variantIds/weights lengths", { - # The weights are per-variant mcols on the entry's element now, so a - # length mismatch cannot be represented. It is refused at construction - # rather than producing a gene that gets silently dropped downstream. - expect_error( - twasWeightsRow( - variantIds = map_chr(1:5, .ctp_snpId), - weights = c(0.1, 0.2, 0.3) - ), - "length\\(weights\\) is 3 but 5 variants were supplied" - ) -}) - test_that(".ctwasBuildWeights: skips a gene when harmonization yields nothing", { local_mocked_bindings( .ctwasHarmonizeWeights = function(...) NULL, @@ -3188,7 +3014,7 @@ test_that(".ctwasBuildWeights: SuSiE renormalization fires when variants are dro mu = rbind(c(1, 2, 3, 4, 5), c(6, 7, 8, 9, 10)), X_column_scale_factors = rep(1, 5L) ) - ent <- twasWeightsRow( + ent <- TwasWeightsRow( variantIds = c(ids4, bogus), weights = c(0.1, 0.2, 0.3, 0.4, 0.5), methodFits = fits @@ -3252,9 +3078,9 @@ test_that(".ctwasGetFinemapAux: parses pip + cs_95 membership + purity", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) ) - aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1", "susie") + aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1") expect_equal(aux$pip[["chr1:200:G:A"]], 0.6) expect_length(aux$csMembers, 2L) expect_setequal(aux$csMembers[[1L]], c("chr1:100:G:A", "chr1:200:G:A")) @@ -3274,9 +3100,9 @@ test_that(".ctwasGetFinemapAux: cs_95 without a purity column yields NA purity", context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) ) - aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1", "susie") + aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1") expect_length(aux$csMembers, 1L) expect_setequal(aux$csMembers[[1L]], c("chr1:100:A:G", "chr1:200:A:G")) expect_true(all(is.na(aux$csPurity))) @@ -3293,9 +3119,9 @@ test_that(".ctwasGetFinemapAux: no cs_95 column yields empty CS membership", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) ) - aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1", "susie") + aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1") expect_length(aux$csMembers, 0L) expect_length(aux$csPurity, 0L) expect_equal(aux$pip[["chr1:200:A:G"]], 0.8) @@ -3315,9 +3141,9 @@ test_that(".ctwasGetFinemapAux: a cs_95 column naming no set yields none", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) ) - aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1", "susie") + aux <- pecotmr:::.ctwasGetFinemapAux(fmr, "Q1", "c1", "t1") expect_length(aux$csMembers, 0L) expect_identical(aux$csPurity, numeric(0)) expect_equal(aux$pip[["chr1:200:A:G"]], 0.3) @@ -3347,7 +3173,7 @@ test_that(".ctwasFixMolecularId: rows without a gene id are left alone", { }) test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci all return NULL", { - expect_null(pecotmr:::.ctwasGetFinemapAux(NULL, "Q1", "c1", "t1", "susie")) + expect_null(pecotmr:::.ctwasGetFinemapAux(NULL, "Q1", "c1", "t1")) tl <- data.frame( variant_id = "chr1:100:A:G", pip = 0.5, @@ -3358,25 +3184,19 @@ test_that(".ctwasGetFinemapAux: NULL input, no-match tuple, and empty topLoci al context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(tl$variant_id, NULL, tl)) + entry = list(FineMappingRow(tl$variant_id, NULL, tl)) ) # No matching (study, context, trait, method) tuple -> NULL. - expect_null(pecotmr:::.ctwasGetFinemapAux(fmr, "NOPE", "c1", "t1", "susie")) + expect_null(pecotmr:::.ctwasGetFinemapAux(fmr, "NOPE", "c1", "t1")) # Matching tuple but an empty topLoci -> NULL. fmrEmpty <- QtlFineMappingResult( studyName = "Q1", context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow(character(0), NULL, data.frame())) + entry = list(FineMappingRow(character(0), NULL, data.frame())) ) - expect_null(pecotmr:::.ctwasGetFinemapAux( - fmrEmpty, - "Q1", - "c1", - "t1", - "susie" - )) + expect_null(pecotmr:::.ctwasGetFinemapAux(fmrEmpty, "Q1", "c1", "t1")) }) # =========================================================================== @@ -3403,7 +3223,7 @@ test_that(".ctwasSnpInfoForGwasBlock: returns an empty frame when the block has entry = list(gr), genome = "hg19", ldReference = .ctp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) panelInfo <- data.frame( chrom = 1L, @@ -3498,7 +3318,7 @@ test_that(".ctwasRunToRows: empty weights -> no rows; a context mixing studies e test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped", { mkE <- function() { - twasWeightsRow( + TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) @@ -3529,7 +3349,7 @@ test_that(".ctwasBucketWeights: unplaced genes warn + drop; empty blocks skipped test_that(".ctwasBucketWeights: errors when no gene lands in any block", { mkE <- function() { - twasWeightsRow( + TwasWeightsRow( variantIds = map_chr(1:5, .ctp_snpId), weights = c(0.1, 0.05, -0.2, 0.3, 0.0) ) @@ -3558,7 +3378,8 @@ test_that("assembleCtwasInputs: single-block + NULL twasWeights guards", { expect_error( assembleCtwasInputs( .ctp_makeGwasSumstats(blockIds = "block1"), - .ctp_makeTwasWeights() + .ctp_makeTwasWeights(), + method = "susie" ), "at least two LD blocks" ) @@ -3573,7 +3394,7 @@ test_that("weight-source / method / gwas-study guards reject degenerate input", pecotmr:::.ctwasRequireNamedLists(.ctp_makeGwasSumstats(), 42), "must be a TwasWeights" ) - expect_error(pecotmr:::.ctwasResolveMethods(list()), "no method entries") + expect_error(pecotmr:::.ctwasResolveMethod(list()), "no method entries") expect_error( pecotmr:::.ctwasGwasStudyFromZSnp(data.frame(study = c("D1", "D2"))), "multiple GWAS studies" @@ -3637,27 +3458,18 @@ test_that("bundled cTWAS payloads carry one resolvable token per region", { expect_equal(length(unique(live)), nrow(payload$LD_map)) loader <- resolved$LD_loader_fun panels <- pecotmr:::.ctwasCachedPanels(resolved) + # Both loader closures are re-keyed onto the new tokens; rewriting + # LD_map alone would leave them unable to find their panels. for (i in seq_along(live)) { expect_equal( loader(live[[i]]), pecotmr:::.ctwasPanelLd(panels[[i]]) ) + expect_false(is.null(resolved$snpinfo_loader_fun(live[[i]]))) } } }) -test_that("resolving the LD token keeps the loader cache keys in step", { - data(ctwasEstExample) - resolved <- pecotmr:::.ctwasResolveLdPaths(ctwasEstExample) - token <- resolved$LD_map$LD_file[[1]] - - # Rewriting LD_map without re-keying the closures would leave the loader - # unable to find its panel -- the failure this pairing exists to prevent. - expect_true(file.exists(token)) - expect_true(is.matrix(resolved$LD_loader_fun(token))) - expect_false(is.null(resolved$snpinfo_loader_fun(token))) -}) - test_that("an ordinary LD path is left alone", { # A token still on disk -- the caller's own file, or this session's # sentinel -- needs nothing re-minted. @@ -3882,6 +3694,39 @@ test_that("row coordinates prefer the gene cache, then the variant id", { expect_null(f(1L, "rsNOTPARSEABLE", NULL)) }) +test_that("ranged results drop only the rows they cannot place, saying so", { + df <- data.frame( + id = c("chr1:100:A:G", "geneX", "geneY", "rsNOTPARSEABLE"), + susie_pip = c(0.1, 0.2, 0.3, 0.4) + ) + gc <- list(geneX = list(chrom = "chr1", start = 500L, end = 900L)) + expect_warning( + out <- pecotmr:::.ctwasRangePayload(df, gc), + "2 result row\\(s\\) could not be placed on the genome" + ) + expect_s4_class(out, "GRanges") + expect_equal(out$id, c("chr1:100:A:G", "geneX")) + expect_equal(start(out), c(100L, 500L)) + expect_equal(end(out), c(100L, 900L)) +}) + +test_that("a table with no placeable row stays whole, without a warning", { + df <- data.frame(id = c("geneY", "rsNOTPARSEABLE"), susie_pip = c(0.3, 0.4)) + expect_no_warning(out <- pecotmr:::.ctwasRangePayload(df, NULL)) + expect_identical(out, df) + expect_null(pecotmr:::.ctwasRangePayload(NULL, NULL)) +}) + +test_that("the unplaced-row warning names at most five ids", { + cnd <- tryCatch( + pecotmr:::.ctwasWarnUnplaced(sprintf("gene%d", 1:7)), + warning = identity + ) + expect_match(conditionMessage(cnd), "7 result row\\(s\\)") + expect_equal(stringr::str_count(conditionMessage(cnd), "gene[0-9]"), 5L) + expect_null(pecotmr:::.ctwasWarnUnplaced(character(0))) +}) + test_that("trait positions are NULL when the weights do not carry them", { data(twasWeightsExample) expect_false( @@ -4008,23 +3853,6 @@ test_that(".ctwasPrefitRegionFilter honours min_var = 0 and min_gene = 0", { ) }) -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. - gr <- suppressWarnings( - pecotmr:::.ctwasBlockGrFromIds(c("chr1_100_200", "not-a-region")) - ) - expect_equal( - as.character(GenomicRanges::seqnames(gr)), - c("chr1", "chrUn") - ) - # start = 1, end = 0 is a deliberately EMPTY range, so an unplaced block - # overlaps nothing rather than silently matching everything. - expect_equal(GenomicRanges::start(gr), c(100L, 1L)) - expect_equal(GenomicRanges::end(gr), c(200L, 0L)) - expect_equal(GenomicRanges::width(gr)[[2L]], 0L) -}) - test_that(".ctwasCoordField falls back for an unplaced feature", { expect_equal(pecotmr:::.ctwasCoordField(NULL, "chrom"), "chrUnplaced") expect_equal(pecotmr:::.ctwasCoordField2(NULL, "start"), 1L) @@ -4044,11 +3872,11 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { genome = "hg19", blockId = "b1" ) - # Emptiness is checked before the chromosome count -- otherwise a block - # with no variants is reported as spanning "multiple chromosomes ()". + # Emptiness is checked before the window -- a block empty from the start + # has only a placeholder for one. expect_error( pecotmr:::.ctwasBuildSingleRegionInfo("b1", gss), - "has no variants to define region bounds" + "has no variants for cTWAS to fit" ) }) @@ -4070,13 +3898,13 @@ test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { entry = list(mkGr("chr1", c(100L, 200L)), mkGr("chr1", c(300L, 400L))), genome = "hg19", blockId = c("b1", "b2"), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) } test_that(".ctwasFirstPass requires an LD reference on every region", { byBlock <- pecotmr:::.ctwasGwasByBlock(.ctp_noLdGwas()) - expect_null(ldReference(byBlock[[1L]])) + expect_identical(ldReference(byBlock[[1L]]), list()) expect_error( pecotmr:::.ctwasFirstPass("b1", byBlock, list(b1 = NULL)), "region 'b1' carries no ldReference" @@ -4086,7 +3914,7 @@ test_that(".ctwasFirstPass requires an LD reference on every region", { test_that("ctwasPipeline aborts when no genes could be modeled", { local_mocked_bindings( .ctwasRequireNamedLists = function(...) invisible(NULL), - .ctwasResolveMethods = function(...) "susie", + .ctwasResolveMethod = function(...) "susie", .ctwasGwasStudy = function(...) "G1", .ctwasRunMethod = function(...) list(), .package = "pecotmr" @@ -4098,12 +3926,12 @@ test_that("ctwasPipeline aborts when no genes could be modeled", { }) test_that(".ctwasAlignGeneWeights returns NULL when the row has no variants", { - row <- twasWeightsRow(variantIds = character(0), weights = numeric(0)) + row <- TwasWeightsRow(variantIds = character(0), weights = numeric(0)) expect_null(pecotmr:::.ctwasAlignGeneWeights(row, NULL, NULL)) }) test_that(".ctwasTraitPosAt is bounded by the traitPos column length", { - row <- fineMappingRow( + row <- FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:C:T"), susieFit = list(pip = c(0.8, 0.2)), topLoci = data.frame( @@ -4164,31 +3992,27 @@ test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { }) test_that(".ctwasResolveAndValidateWeights requires region_id names", { - local_mocked_bindings( - .ctwasResolveWeightBuckets = function(twasWeights, gwasSumStats) { - list("a", "b") - }, - .package = "pecotmr" - ) - expect_error( - pecotmr:::.ctwasResolveAndValidateWeights(list(x = 1), NULL), - "must resolve to a named list keyed by region_id" + # A partially-named list is as unusable as an unnamed one: the blank key + # cannot address a region. + buckets <- list( + unnamed = list("a", "b"), + blank = stats::setNames(list("a", "b"), c("r1", "")) ) -}) - -test_that(".ctwasResolveAndValidateWeights rejects a blank region name", { + current <- NULL local_mocked_bindings( .ctwasResolveWeightBuckets = function(twasWeights, gwasSumStats) { - stats::setNames(list("a", "b"), c("r1", "")) + current }, .package = "pecotmr" ) - # A partially-named list is as unusable as an unnamed one: the blank key - # cannot address a region. - expect_error( - pecotmr:::.ctwasResolveAndValidateWeights(list(x = 1), NULL), - "must resolve to a named list keyed by region_id" - ) + for (nm in names(buckets)) { + current <- buckets[[nm]] + expect_error( + pecotmr:::.ctwasResolveAndValidateWeights(list(x = 1), NULL), + "must resolve to a named list keyed by region_id", + info = nm + ) + } }) test_that("asCtwasResult: keepSnps must be a flag", { @@ -4201,7 +4025,6 @@ test_that("asCtwasResult: keepSnps must be a flag", { test_that("the ctwas concat helpers answer an empty vector of their own type", { expect_identical(pecotmr:::.ctwasConcat(list()), list()) - expect_identical(pecotmr:::.ctwasConcatInt(list()), integer(0)) expect_identical(pecotmr:::.ctwasConcatChr(list()), character(0)) }) @@ -4240,3 +4063,217 @@ test_that("ctwas reads variance and LD from an LdMatrix block", { # An LdMatrix has no file payload to check. expect_null(.ctwasLdPanelKey(bare)) }) + +test_that(".ctwasRegionGwasLd refuses a region whose rows use two references", { + # A region's LD is one matrix, so its GWAS rows must share a reference. + gwas <- .ctp_makeGwasSumstats(blockIds = c("blockA", "blockA")) + gwas <- pecotmr:::.withRowLdRefs( + gwas, + list(.ctp_makeHandle(snp_n = 12L), .ctp_makeHandle(snp_n = 6L)) + ) + expect_error( + pecotmr:::.ctwasRegionGwasLd(1L, list(gwas), list()), + "2 different LD references; a region's LD is one matrix" + ) +}) + +# =========================================================================== +# The rescues read the fine-mapping method they are told to +# =========================================================================== + +# A gene's fine-mapping under two methods that disagree about variant 3: susie +# puts its PIP at 0.9, susieInf at 0.01. +.ctp_twoMethodRescue <- function(vids) { + fit <- function(pip3, rest) { + pip <- rep(rest, 5L) + pip[[3L]] <- pip3 + FineMappingRow( + variantIds = vids, + susieFit = list(), + topLoci = data.frame(variant_id = vids, pip = pip) + ) + } + QtlFineMappingResult( + studyName = rep("study1", 2L), + context = rep("brain", 2L), + trait = rep("ENSG_example", 2L), + method = c("susie", "susieInf"), + entry = list(fit(0.9, 0.05), fit(0.01, 0.2)) + ) +} + +test_that(".ctwasRescueSource narrows the result to the named method", { + data(qtlDatasetExample) + vids <- .ctp_panelSnpInfo(pecotmr:::.qtlGenotypeSe(qtlDatasetExample))$SNP + fmr <- .ctp_twoMethodRescue(vids[1:5]) + expect_null(pecotmr:::.ctwasRescueSource(NULL, NULL)) + narrowed <- pecotmr:::.ctwasRescueSource(fmr, "susieInf") + expect_identical(as.character(narrowed$method), "susieInf") + expect_error( + pecotmr:::.ctwasRescueSource(fmr, NULL), + "must name the method of it .*available: susie, susieInf" + ) + expect_error( + pecotmr:::.ctwasRescueSource(fmr, "ensemble"), + "'ensemble' is not a method of `fineMappingResult`" + ) + expect_error( + pecotmr:::.ctwasRescueSource(NULL, "susie"), + "names a method of `fineMappingResult`, which was not given" + ) +}) + +test_that("an ensemble gene is rescued by the fine-mapping method named", { + data(qtlDatasetExample) + gh <- pecotmr:::.qtlGenotypeSe(qtlDatasetExample) + vids <- .ctp_panelSnpInfo(gh)$SNP[1:5] + # Variant 3 carries the smallest weight, so the cap drops it unless a + # rescue keeps it. + tw <- TwasWeights( + studyName = "study1", + context = "brain", + trait = "ENSG_example", + method = "ensemble", + entry = list(TwasWeightsRow( + variantIds = vids, + weights = c(0.1, -0.2, 0.05, 0.3, 0.15) + )), + ldReference = gh + ) + fmr <- .ctp_twoMethodRescue(vids) + kept <- function(fineMappingMethod) { + wl <- pecotmr:::.ctwasBuildWeights( + tw, + .ctp_fullPanel(gh), + fineMappingResult = pecotmr:::.ctwasRescueSource( + fmr, + fineMappingMethod + ), + minPipCutoff = 0.5, + maxNumVariants = 3L + ) + rownames(wl[[1L]]$wgt) + } + expect_true(vids[[3L]] %in% kept("susie")) + expect_false(vids[[3L]] %in% kept("susieInf")) +}) + +# =========================================================================== +# Narrowed rows: the SuSiE fits that renormalize weights +# =========================================================================== + +# One gene's SuSiE weights on variants `variantIdx`, fitted on all five and +# narrowed to the first four; `fits` is the stored fit. +.ctp_narrowedSusieWeights <- function( + variantIdx = 1:5, + method = "susie", + fits = list( + alpha = matrix(0.2, 1L, 5L), + mu = matrix(0.1, 1L, 5L), + X_column_scale_factors = rep(1, 5L) + ) +) { + tw <- TwasWeights( + studyName = "Q1", + context = "c1", + trait = "t1", + method = method, + entry = list(TwasWeightsRow( + variantIds = map_chr(variantIdx, .ctp_snpId), + weights = c(0.1, 0.05, -0.2, 0.3, 0.0), + methodFits = fits + )), + ldReference = .ctp_makeHandle() + ) + endoapply(tw, utils::head, 4L) +} + +test_that("the narrowed rows checked are SuSiE-fitted rows of the method", { + narrowed <- .ctp_narrowedSusieWeights() + cnd <- tryCatch( + pecotmr:::.ctwasCheckFitCoverage( + list(block1 = narrowed, block2 = .ctp_narrowedSusieWeights(7:11)), + "susie", + "f()" + ), + warning = identity + ) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_match(conditionMessage(cnd), "f\\(\\): 2 row\\(s\\)") + # Another method's rows are not read. + expect_no_warning( + pecotmr:::.ctwasCheckFitCoverage(narrowed, "lasso", "f()") + ) + # Nor is a fit that is not SuSiE's, which renormalizes nothing. + lasso <- .ctp_narrowedSusieWeights( + method = "lasso", + fits = list(beta = rep(0.1, 5L)) + ) + expect_null(pecotmr:::.ctwasSusieFitRows(lasso, "lasso")) + expect_no_warning(pecotmr:::.ctwasCheckFitCoverage(lasso, "lasso", "f()")) + # A fine-mapping weight source gives its topLoci effects, not its fit. + vids <- map_chr(1:5, .ctp_snpId) + tl <- data.frame(variant_id = vids, pip = rep(0.2, 5L)) + fmr <- QtlFineMappingResult( + studyName = "Q1", + context = "c1", + trait = "t1", + method = "susie", + entry = list(FineMappingRow(vids, list(pip = tl$pip), tl)) + ) + expect_no_warning(pecotmr:::.ctwasCheckFitCoverage( + list(block1 = endoapply(fmr, utils::head, 4L)), + "susie", + "f()" + )) +}) + +test_that("assembleCtwasInputs warns about narrowed SuSiE weights", { + skip_if_not_installed("ctwas") + local_mocked_bindings( + extractBlockGenotypes = .ctp_mockExtractor(), + .package = "pecotmr" + ) + cnd <- .fitCoverageCondition(assembleCtwasInputs( + gwasSumStats = .ctp_makeGwasSumstats(), + twasWeights = list( + block1 = .ctp_narrowedSusieWeights(), + block2 = .ctp_narrowedSusieWeights(7:11) + ), + method = "susie" + )) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_match(conditionMessage(cnd), "assembleCtwasInputs\\(\\): 2 row") +}) + +# A stand-in for assembleCtwasInputs() that warns as it does about a narrowed +# row, then stops the run. +.ctp_warnThenStop <- function(...) { + warn("assembleCtwasInputs(): narrowed", class = "pecotmrFitCoverage") + abort("assembled") +} + +test_that("ctwasPipeline warns once, under its own name", { + skip_if_not_installed("ctwas") + local_mocked_bindings( + assembleCtwasInputs = .ctp_warnThenStop, + .package = "pecotmr" + ) + msgs <- character(0) + expect_error( + withCallingHandlers( + ctwasPipeline( + gwasSumStats = .ctp_makeGwasSumstats(), + twasWeights = .ctp_narrowedSusieWeights(), + method = "susie" + ), + pecotmrFitCoverage = function(w) { + msgs <<- c(msgs, conditionMessage(w)) + invokeRestart("muffleWarning") + } + ), + "assembled" + ) + expect_length(msgs, 1L) + expect_match(msgs, "ctwasPipeline\\(\\): 1 row") +}) diff --git a/tests/testthat/test_ctwasWrapper.R b/tests/testthat/test_ctwasWrapper.R index 79e0602d..ba7f6639 100644 --- a/tests/testthat/test_ctwasWrapper.R +++ b/tests/testthat/test_ctwasWrapper.R @@ -30,7 +30,7 @@ test_that("the geneZ bundle reaches compute_gene_z", { ) pecotmr:::.ctwasEnsureZGene( inputs, - numThreads = 1L, + threads = 1L, extra = CtwasGeneZOptions(logfile = "gene-z.log") ) expect_equal(seen$logfile, "gene-z.log") @@ -38,7 +38,7 @@ test_that("the geneZ bundle reaches compute_gene_z", { # A supplied z_gene still short-circuits without calling the engine. seen <- NULL inputs$z_gene <- data.frame(id = "t1", z = 2.0) - pecotmr:::.ctwasEnsureZGene(inputs, numThreads = 1L) + pecotmr:::.ctwasEnsureZGene(inputs, threads = 1L) expect_null(seen) }) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index 0333eb86..0a88a8df 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -18,7 +18,7 @@ context("fineMappingPipeline") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -136,7 +136,7 @@ context("fineMappingPipeline") gr } -.fmp_makeQtlSumStats <- function(qc = TRUE) { +.fmp_makeQtlSumStats <- function(qc = TRUE, traitPos = NULL) { QtlSumStats( studyName = "Q1", context = "c1", @@ -144,24 +144,67 @@ context("fineMappingPipeline") entry = list(.fmp_makeSumstatsGr()), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list(), + traitPos = traitPos ) } +# A trait position for the summary statistics above: a MultiStudyQtlDataset +# lays its `cisWindow` there too, and 1000 bp around it keeps every variant. +.fmp_traitPos <- function() { + GenomicRanges::GRanges("chr1:300") +} + .fmp_makeGwasSumStats <- function(qc = TRUE, studyName = "G1") { GwasSumStats( studyName = studyName, entry = list(.fmp_makeSumstatsGr()), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list() ) } +# The fixtures most tests read, built once: every constructor validates its +# whole collection, so rebuilding them in each test was a large share of this +# file's run time. Tests only read them (a change makes a local copy). +.fmp_qdA <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") +.fmp_qdAB <- .fmp_makeQtlDataset() +.fmp_qss <- .fmp_makeQtlSumStats() +.fmp_gss <- .fmp_makeGwasSumStats() +.fmp_qdTwoCtxA <- .fmp_makeQtlDataset( + contexts = c("brain", "liver"), + traits = "ENSG_A" +) +.fmp_qdTwoCtxAB <- .fmp_makeQtlDataset(contexts = c("brain", "liver")) +# One individual-level study plus embedded summary statistics placed at +# .fmp_traitPos(), so a `cisWindow` can be laid on both. +.fmp_msqd <- MultiStudyQtlDataset( + qtlDatasets = list(study1 = .fmp_qdA), + sumStats = .fmp_makeQtlSumStats(traitPos = .fmp_traitPos()) +) + +# The result class each summary-statistics input comes back as. +.fmp_resultClass <- c( + GwasSumStats = "GwasFineMappingResult", + QtlSumStats = "QtlFineMappingResult" +) + +# One susie fit of a summary-statistics input under `susieRssParam`. +.fmp_fitRss <- function(input, susieRssParam = SusieRssParam()) { + suppressMessages(fineMappingPipeline( + input, + methods = "susie", + initializeWithSusieInf = FALSE, + susieRssParam = susieRssParam + )) +} + # Mocks for the SuSiE fitters + post-processor. Return tiny payloads keyed # only by the token so post-process knows what to wrap. The `userArgs` -# parameter (per-method kwargs merged in by .fmMergeUserArgs) is accepted -# but ignored — the mocks don't simulate downstream susie behaviour. +# parameter (per-method kwargs merged in by .fmMergeUserArgs) is recorded +# when a `capture` environment is given and otherwise ignored -- the mocks +# don't simulate downstream susie behaviour. .fmp_mockFitIndiv <- function(capture = NULL) { function( X, @@ -264,7 +307,7 @@ context("fineMappingPipeline") if (is.null(vids)) { vids <- "chr1:1200:A:G" } - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(method = method, payload = fit), topLoci = data.frame( @@ -430,26 +473,6 @@ test_that(".fmCheckMethodCapabilities: mvsusie on GwasSumStats rejected", { ) }) -test_that(".fmTraitsInRegion: keeps genes overlapping the region; NULL keeps all", { - # g1: 1000-1500, g2: 2000-2500, g3: 3000-3500 (width 500). - se <- .fmp_makeSe( - traits = c("g1", "g2", "g3"), - starts = c(1000L, 2000L, 3000L) - ) - r1 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900L, 1600L)) # g1 only - r12 <- GenomicRanges::GRanges("chr1", IRanges::IRanges(900L, 2600L)) # g1 + g2 - expect_equal(pecotmr:::.fmTraitsInRegion(se, c("g1", "g2", "g3"), r1), "g1") - expect_setequal( - pecotmr:::.fmTraitsInRegion(se, c("g1", "g2", "g3"), r12), - c("g1", "g2") - ) - # NULL region (gene/cisWindow mode) leaves the set unchanged. - expect_setequal( - pecotmr:::.fmTraitsInRegion(se, c("g1", "g2", "g3"), NULL), - c("g1", "g2", "g3") - ) -}) - # =========================================================================== # .fmResolveSusieChain # =========================================================================== @@ -473,7 +496,7 @@ test_that(".fmResolveSusieChain: keeps susieInf when explicitly requested", { expect_true(res$keepInf) }) -test_that(".fmResolveSusieChain: no chain when addSusieInf=FALSE", { +test_that(".fmResolveSusieChain: no chain or susieInf run for susie alone", { res <- pecotmr:::.fmResolveSusieChain( c("susie"), initializeWithSusieInf = FALSE @@ -491,7 +514,7 @@ test_that(".fmCacheLookup: NULL fineMappingResult returns NULL", { }) test_that(".fmCacheLookup: returns matching entry by 4-tuple", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -521,7 +544,7 @@ test_that(".fmCacheLookup: returns matching entry by 4-tuple", { }) test_that(".fmCacheLookupGwas: matches on study/method/blockId", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -530,9 +553,9 @@ test_that(".fmCacheLookupGwas: matches on study/method/blockId", { stringsAsFactors = FALSE ) ) - # GwasFineMappingResult assigns the synthetic blockId "region_1" - # when none is supplied; the lookup must include it in the 3-tuple - # key (multi-block FMRs disambiguate per-block fits by blockId). + # GwasFineMappingResult names a row with no blockId by its own span; the + # lookup keys on that span (multi-block FMRs disambiguate per-block fits + # by it). fmr <- GwasFineMappingResult( studyName = "g1", method = "susie", @@ -551,9 +574,24 @@ test_that(".fmCacheLookupGwas: matches on study/method/blockId", { expect_null(pecotmr:::.fmCacheLookupGwas(fmr, "ghost", "susie", key)) }) +test_that(".fmCacheLookupGwas: a one-block cache answers for that block only", { + # A cache holding one block of a study is no fit for its other blocks, so + # the range is compared even when only one row matches (study, method). + fmr <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)) + ) + key <- pecotmr:::.rtlRangeKeys(fmr)[[1L]] + expect_false(is.null( + pecotmr:::.fmCacheLookupGwas(fmr, "g1", "susie", key) + )) + expect_null( + pecotmr:::.fmCacheLookupGwas(fmr, "g1", "susie", "chr1_10100_10300") + ) +}) + test_that(".fmCacheLookupGwas: the range key disambiguates multi-block FMRs", { - # With one row per (study, method) the range never has to be consulted; - # it only becomes load-bearing once a study is swept across blocks. e1 <- .sc_makeFineMappingRow(3) e2 <- .sc_makeFineMappingRow(3, offset = 10000L) fmr <- GwasFineMappingResult( @@ -574,7 +612,7 @@ test_that(".fmCacheLookupGwas: the range key disambiguates multi-block FMRs", { }) test_that(".fmCacheLookup: non-QtlFineMappingResult input returns NULL", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -591,26 +629,6 @@ test_that(".fmCacheLookup: non-QtlFineMappingResult input returns NULL", { expect_null(pecotmr:::.fmCacheLookup(gwasFmr, "g1", "c1", "t1", "susie")) }) -test_that(".fmCacheLookupGwas: non-GwasFineMappingResult input returns NULL", { - e <- fineMappingRow( - variantIds = "chr1:100:A:G", - susieFit = list(token = "susie"), - topLoci = data.frame( - variant_id = "chr1:100:A:G", - pip = 0.5, - stringsAsFactors = FALSE - ) - ) - qtlFmr <- QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(e) - ) - expect_null(pecotmr:::.fmCacheLookupGwas(qtlFmr, "s1", "susie", "region_1")) -}) - # =========================================================================== # .fmBuildQtlResult / .fmBuildGwasResult — empty-entries errors # =========================================================================== @@ -640,7 +658,7 @@ test_that(".fmBuildGwasResult: empty entries errors", { # =========================================================================== test_that(".rbindFineMappingResult: rejects non-FineMappingResultBase input", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -667,7 +685,7 @@ test_that(".rbindFineMappingResult: rejects non-FineMappingResultBase input", { }) test_that(".rbindFineMappingResult: rejects mixed Qtl/Gwas inputs", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -695,7 +713,7 @@ test_that(".rbindFineMappingResult: rejects mixed Qtl/Gwas inputs", { }) test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult collections", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -720,7 +738,7 @@ test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult colle }) test_that("combineFineMappingResults: row-binds same-class collections; rejects mixed class/empty", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(token = "susie"), topLoci = data.frame( @@ -776,11 +794,7 @@ test_that(".fmExtractZn: errors on missing SNP / Z / N columns", { # fineMappingPipeline(QtlDataset) # =========================================================================== -test_that("fineMappingPipeline(QtlDataset): runs univariate dispatch with mocked fitters", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) +test_that("fineMappingPipeline(QtlDataset): univariate rows record traitPos", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -789,7 +803,7 @@ test_that("fineMappingPipeline(QtlDataset): runs univariate dispatch with mocked ) res <- suppressMessages( fineMappingPipeline( - qd, + .fmp_qdAB, methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE @@ -799,27 +813,6 @@ test_that("fineMappingPipeline(QtlDataset): runs univariate dispatch with mocked # 1 context x 2 traits x 1 method = 2 rows. expect_equal(nrow(res), 2L) expect_setequal(methodNames(res), "susie") -}) - -test_that("fineMappingPipeline(QtlDataset): threads real trait positions into traitPos provenance", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieIndiv = .fmp_mockFitIndiv(), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - qd, - methods = "susie", - cisWindow = 1000L, - initializeWithSusieInf = FALSE - ) - ) tp <- traitPosition(res) expect_s4_class(tp, "GRanges") expect_length(tp, nrow(res)) @@ -835,7 +828,7 @@ test_that("fineMappingPipeline(QtlDataset): threads real trait positions into tr expect_equal(ent[["ENSG_B"]], 2499L) # genomicRegion() reports the REALIZED variant span now, not the nominal cis # window (traitPos +/- cisWindow). The window is gone because it had no - # correct update rule under subsetRegion(); the span is in sync with the + # correct update rule under subsetting; the span is in sync with the # variants by construction. It still sits inside the window the fit was # drawn from, which is what this checks. reg <- genomicRegion(res) @@ -848,7 +841,7 @@ test_that("fineMappingPipeline(QtlDataset): threads real trait positions into tr }) test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X)", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .package = "pecotmr" @@ -865,17 +858,21 @@ test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X c("chr1:300:A:G", "chr1:100:A:G", "chr1:200:A:G") ) ) - af <- pecotmr:::.fmAfForX(qd, X, region = region) + noFilter <- pecotmr:::.qtlResolveFilter() + af <- pecotmr:::.fmAfForX(qd, X, genotypeFilter = noFilter, region = region) expect_length(af, 3L) expect_false(anyNA(af)) # region matched -> every fitted variant has an af - expect_equal( - af, - unname(af(qd, region = region, samples = rownames(X))[colnames(X)]) + blk <- pecotmr:::.qtlExtractBlock( + qd, + window = region, + samples = rownames(X), + filter = noFilter ) + expect_equal(af, unname(setNames(blk$af, blk$variantIds)[colnames(X)])) }) test_that(".fmAfForX: returns NULL for an empty block or a non-QtlDataset source", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA emptyX <- matrix(numeric(0), nrow = 0L, ncol = 0L) expect_null(pecotmr:::.fmAfForX(qd, emptyX)) X <- matrix( @@ -891,7 +888,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc # Regression for af = NA in credibleSets: the individual-level univariate path must # forward a non-NULL, directional effect-allele frequency to the # post-processor (which writes it into the topLoci `af` column). - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA captured <- new.env(parent = emptyenv()) captured$af <- "UNSET" captured$cols <- NULL @@ -913,7 +910,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc captured$af <- af captured$cols <- colnames(dataX) vids <- colnames(dataX) - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(method = method), topLoci = data.frame( @@ -947,7 +944,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc }) test_that("fineMappingPipeline(QtlDataset): seed argument is accepted and runs", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -967,7 +964,7 @@ test_that("fineMappingPipeline(QtlDataset): seed argument is accepted and runs", expect_equal(nrow(res), 1L) }) -test_that(".fmTopPcScores: clean matrix -> samples x min(nPCs, traits) topPC scores", { +test_that(".fmTopPcScores: samples x min(nPCs, traits) scores, else NULL", { set.seed(7) n <- 30L Y <- matrix( @@ -1001,12 +998,14 @@ test_that(".fmTopPcScores: clean matrix -> samples x min(nPCs, traits) topPC sco scn <- fn(Yna, 10L) expect_equal(nrow(scn), n - 2L) expect_false(any(c("s1", "s2") %in% rownames(scn))) + # (f) fewer than two complete rows, fewer than two traits with variance, + # or nPCs = 0 leaves nothing to score. + expect_null(fn(matrix(c(1, NA), 2, 2), 2L)) + expect_null(fn(cbind(a = rep(1, 4), b = rnorm(4)), 2L)) + expect_null(fn(Y, 0L)) }) -test_that("fineMappingPipeline( - QtlDataset, - usePCA -): top-PC susie rows keyed topPC{i}", { +test_that("fineMappingPipeline(QtlDataset, usePCA): rows keyed topPC{i}", { qd <- .fmp_makeQtlDataset( contexts = "brain", traits = c("ENSG_A", "ENSG_B", "ENSG_C") @@ -1038,7 +1037,7 @@ test_that("fineMappingPipeline( test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { mkEntry <- function(fits) { - twasWeightsRow( + TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), methodFits = fits @@ -1067,7 +1066,7 @@ test_that(".fmLookupMrmashFit: finds the mr.mash fit by (study, trait)", { test_that(".fmLookupMrmashCv: finds the per-fold CV payload by (study, trait)", { mkEntry <- function(cv) { - twasWeightsRow( + TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), cvResult = cv @@ -1187,25 +1186,8 @@ test_that(".fmBuildMvsusiePriorCv: mode C reuses full-fit w0/V with per-fold U", expect_equal(captured[[2]]$mixture_prior$matrices$Z, diag(2) * 3) # fold 2's U }) -test_that("enabling two screen metrics errors at the constructor", { - # It used to take a pipeline call to find this out; now the bundle - # refuses to be built, so the mistake is caught where it is written. - expect_error( - SignalScreenParam(pip = 0.5, absZ = 5), - "only one screening metric" - ) - # 0 is the long-standing "off" spelling, so this is one screen, not two. - expect_equal( - pecotmr:::.screenResolve(SignalScreenParam(pip = 0, absZ = 5)), - list(metric = "absZ", cutoff = 5) - ) -}) - test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univariate traits", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB # Stateful screen: reject the first block (ENSG_A), keep the rest (ENSG_B). seen <- 0L local_mocked_bindings( @@ -1232,12 +1214,9 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips no-signal univ expect_setequal(traitNames(res), "ENSG_B") }) -test_that("fineMappingPipeline( - QtlDataset, - cvFolds>1 -): attaches cvResult end to end", { +test_that("fineMappingPipeline(QtlDataset): CV folds attach a cvResult", { skip_if_not_installed("susieR") - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA # Real susie fits drive CV; the genotype extraction and the full-data # post-processor are mocked (the mock SNP ids are not chr:pos:a1:a2, which the # real buildTopLoci requires). CV runs its own real .fmFitSusieIndiv, so the @@ -1273,11 +1252,8 @@ test_that("fineMappingPipeline( expect_false(anyNA(cv$prediction[["susie_predicted"]])) }) -test_that("fineMappingPipeline( - QtlDataset, - crossValidation = CrossValidationParam(folds = 0) -): leaves cvResult NULL", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") +test_that("fineMappingPipeline(QtlDataset): no CV folds leaves cvResult NULL", { + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -1307,13 +1283,6 @@ test_that("fineMappingPipeline( # tests above). # =========================================================================== -test_that(".cvSamplePartition partitions every sample into the requested folds", { - part <- pecotmr:::.cvSamplePartition(paste0("s", 1:20), fold = 4L) - expect_setequal(part$Sample, paste0("s", 1:20)) - expect_setequal(sort(unique(part$Fold)), 1:4) - expect_equal(nrow(part), 20L) -}) - test_that(".fmWeightsCv returns twasWeightsCv-shaped output keyed by snake method", { skip_if_not_installed("susieR") set.seed(42) @@ -1412,47 +1381,42 @@ test_that(".fmSliceCv / .fmAttachCv slice one method and round-trip onto an entr pip = 0.5, stringsAsFactors = FALSE ) - e <- fineMappingRow("chr1:100:A:G", list(), tl) + e <- FineMappingRow("chr1:100:A:G", list(), tl) e2 <- pecotmr:::.fmAttachCv(e, sl) expect_identical(pecotmr:::.fmrPartsCvResult(e2), sl) }) -test_that("fineMappingPipeline(QtlDataset): RSS-only method rejected by capability check", { - qd <- .fmp_makeQtlDataset() +test_that("fineMappingPipeline(QtlDataset): a TWAS-only method is rejected", { expect_error( - fineMappingPipeline(qd, methods = "mrmash"), + fineMappingPipeline(.fmp_qdAB, methods = "mrmash"), "TWAS-weight-oriented" ) }) test_that("fineMappingPipeline(QtlDataset): unknown context errors", { - qd <- .fmp_makeQtlDataset() expect_error( - fineMappingPipeline(qd, methods = "susie", contexts = "ghost"), + fineMappingPipeline(.fmp_qdAB, methods = "susie", contexts = "ghost"), "no study has: ghost" ) }) -test_that("fineMappingPipeline(QtlDataset): empty traitId filter errors", { - qd <- .fmp_makeQtlDataset(traits = "ENSG_A") +test_that("fineMappingPipeline(QtlDataset): empty trait filter errors", { expect_error( - fineMappingPipeline(qd, methods = "susie", traitId = "ENSG_Z"), + fineMappingPipeline(.fmp_qdA, methods = "susie", traitId = "ENSG_Z"), "no traits selected" ) }) test_that("fineMappingPipeline(QtlDataset): mvsusie with single trait/context rejected", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( - fineMappingPipeline(qd, methods = "mvsusie"), + fineMappingPipeline(.fmp_qdA, methods = "mvsusie"), "mvsusie requires multi-trait or multi-context" ) }) test_that("fineMappingPipeline(QtlDataset): fsusie with single trait rejected", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( - fineMappingPipeline(qd, methods = "fsusie"), + fineMappingPipeline(.fmp_qdA, methods = "fsusie"), "fsusie requires multi-trait" ) }) @@ -1491,10 +1455,7 @@ test_that("fineMappingPipeline(QtlDataset): fsusie with single trait rejected", } test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context dispatch", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1536,7 +1497,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context d }) test_that("fineMappingPipeline(QtlDataset): mvsusie multi-context single-trait dispatch", { - qd <- .fmp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") + qd <- .fmp_qdTwoCtxA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1588,7 +1549,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip drops null contexts test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < 2 contexts survive", { # susie runs alongside so the result still has rows after mvsusie is skipped. - qd <- .fmp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") + qd <- .fmp_qdTwoCtxA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -1617,10 +1578,7 @@ test_that("fineMappingPipeline(QtlDataset): pipCutoffToSkip skips mvsusie when < }) test_that("fineMappingPipeline(QtlDataset): mvsusie both multi falls back to per-context multi-trait", { - qd <- .fmp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdTwoCtxAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1650,17 +1608,14 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the # canonical create_mixture_prior(R=ncol). Routed through the engine, it now # looks up a prior cross-trait mr.mash fit (study, context fixed; trait # match-any) and reweights from it. - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB fitParts <- list( dataDrivenPriorMatrices = list(U = list(K = diag(2)), w = c(K = 1)), w0 = c(K_grid1 = 1), V = diag(2) ) mkE <- function() { - twasWeightsRow( + TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), methodFits = fitParts @@ -1707,10 +1662,7 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait auto-detection USES the }) test_that("fineMappingPipeline(QtlDataset): multi-trait without mrmashPrior keeps the canonical prior", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB sawMixturePrior <- FALSE sawCanonical <- FALSE local_mocked_bindings( @@ -1742,12 +1694,9 @@ test_that("fineMappingPipeline(QtlDataset): multi-trait without mrmashPrior keep test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits the joint fitter", { # All conditions of the cross-trait group are already in the prior partial # result -> the engine reuses the cached entries and never calls mvsusie. - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB cachedEntry <- function() { - fineMappingRow( + FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), susieFit = list(token = "mvsusie_cached"), topLoci = data.frame( @@ -1791,10 +1740,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie resume cache short-circuits }) test_that("fineMappingPipeline(QtlDataset): jointSpec='context' produces one joint row per trait", { - qd <- .fmp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdTwoCtxAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1827,7 +1773,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' produces one joi }) test_that("fineMappingPipeline(QtlDataset): jointSpec='context' + univariate compose without double-fitting mvsusie", { - qd <- .fmp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") + qd <- .fmp_qdTwoCtxA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -1860,10 +1806,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' + univariate com }) test_that("fineMappingPipeline(QtlDataset): jointSpec='context' with only one context skips with message", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1888,10 +1831,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='context' with only one co }) test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' produces one joint row per context", { - qd <- .fmp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdTwoCtxAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1919,10 +1859,7 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' produces one joint }) test_that("fineMappingPipeline(QtlDataset): jointSpec='trait' with fsusie wires fsusieR::susiF", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1960,10 +1897,7 @@ test_that("fineMappingPipeline(QtlDataset): fsusie receives the CredibleSetParam # while nothing did -- the row described the retired fsusieWrapper() while # the pipeline called fitFsusie(). `--L` was silently ignored and susiF # ran at its own default. The mocked susiF records what it was handed. - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -1994,10 +1928,7 @@ test_that("fineMappingPipeline(QtlDataset): fsusie receives the CredibleSetParam }) test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispatch", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -2027,20 +1958,25 @@ test_that("fineMappingPipeline(QtlDataset): fsusie multi-trait per context dispa # fineMappingPipeline(MultiStudyQtlDataset) # =========================================================================== -test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across constituent QtlDatasets", { - qd1 <- QtlDataset( - studyName = "s1", - genotypes = .fmp_makeHandle(), - phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) - ) - qd2 <- QtlDataset( - studyName = "s2", - genotypes = .fmp_makeHandle(), - phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) +# Two individual-level studies of one trait in one context, built once. +.fmp_twoStudies <- MultiStudyQtlDataset( + qtlDatasets = list( + s1 = QtlDataset( + studyName = "s1", + genotypes = .fmp_makeHandle(), + phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) + ), + s2 = QtlDataset( + studyName = "s2", + genotypes = .fmp_makeHandle(), + phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), + genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) + ) ) - mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) +) + +test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across constituent QtlDatasets", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -2049,7 +1985,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across ) res <- suppressMessages( fineMappingPipeline( - mt, + .fmp_twoStudies, methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE @@ -2060,7 +1996,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): aggregates results across expect_equal(nrow(res), 2L) expect_setequal(studyName(res), c("s1", "s2")) # Pure individual-level -> ldReference should be NULL. - expect_null(ldReference(res)) + expect_identical(ldReference(res), list()) }) # A study measured in brain and liver, on the synthetic genotypes. @@ -2110,7 +2046,7 @@ test_that("fineMappingPipeline(MultiStudy): list selections stay per study", { ) }) -test_that("fineMappingPipeline(QtlDataset): traitId chosen per context", { +test_that("fineMappingPipeline(QtlDataset): trait chosen per context", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -2149,15 +2085,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): per-study options are not ) expect_error( suppressMessages(fineMappingPipeline( - MultiStudyQtlDataset( - qtlDatasets = list( - study1 = .fmp_makeQtlDataset( - contexts = "brain", - traits = "ENSG_A" - ) - ), - sumStats = .fmp_makeQtlSumStats() - ), + .fmp_msqd, methods = "susie", cisWindow = 1000L, credibleSetParam = CredibleSetParam(coverage = 0.9), @@ -2182,15 +2110,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): a misspelled option errors # The method no longer takes `...`, so a typo cannot be swallowed. expect_error( fineMappingPipeline( - MultiStudyQtlDataset( - qtlDatasets = list( - study1 = .fmp_makeQtlDataset( - contexts = "brain", - traits = "ENSG_A" - ) - ), - sumStats = .fmp_makeQtlSumStats() - ), + .fmp_msqd, methods = "susie", credibelSet = CredibleSetParam() ), @@ -2201,12 +2121,6 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): a misspelled option errors test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { # One individual-level study and one embedded QtlSumStats, so both # per-study workers (.fmPerStudy and .fmSumStats) are exercised. - mt <- MultiStudyQtlDataset( - qtlDatasets = list( - study1 = .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - ), - sumStats = .fmp_makeQtlSumStats() - ) capX <- new.env(parent = emptyenv()) capRss <- new.env(parent = emptyenv()) local_mocked_bindings( @@ -2218,7 +2132,7 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { ) suppressMessages( fineMappingPipeline( - mt, + .fmp_msqd, methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE, @@ -2239,19 +2153,6 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { }) test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges per region in each study", { - qd1 <- QtlDataset( - studyName = "s1", - genotypes = .fmp_makeHandle(), - phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) - ) - qd2 <- QtlDataset( - studyName = "s2", - genotypes = .fmp_makeHandle(), - phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) - ) - mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd1, s2 = qd2)) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -2263,7 +2164,7 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges IRanges::IRanges(c(50L, 350L), c(350L, 650L)) ) res <- suppressMessages(fineMappingPipeline( - mt, + .fmp_twoStudies, methods = "susie", traitId = "ENSG_A", region = regions, @@ -2285,14 +2186,6 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointRegions=FALSE merges }) test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { - qd <- QtlDataset( - studyName = "s1", - genotypes = .fmp_makeHandle(), - phenotypes = list(brain = .fmp_makeSe(traits = "ENSG_A")), - genotypeCovariates = matrix(numeric(0), nrow = 0, ncol = 0) - ) - ss <- .fmp_makeQtlSumStats() - mt <- MultiStudyQtlDataset(qtlDatasets = list(s1 = qd), sumStats = ss) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -2302,7 +2195,7 @@ test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { ) res <- suppressMessages( fineMappingPipeline( - mt, + .fmp_msqd, methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE @@ -2311,49 +2204,57 @@ test_that("fineMappingPipeline(MSQD): embedded sumstats record ldReference", { expect_s4_class(res, "QtlFineMappingResult") expect_true(nrow(res) >= 2L) # Embedded sumstats has an LD sketch -> the merged result carries it. - expect_s4_class(ldReference(res), "RangedSummarizedExperiment") + expect_s4_class(ldReference(res)[[1L]], "RangedSummarizedExperiment") }) # =========================================================================== -# fineMappingPipeline(QtlSumStats) +# fineMappingPipeline(QtlSumStats) and fineMappingPipeline(GwasSumStats) # =========================================================================== -test_that("fineMappingPipeline(QtlSumStats): runs end-to-end with mocked RSS fitters", { - ss <- .fmp_makeQtlSumStats() +test_that("fineMappingPipeline(*SumStats): runs with mocked RSS fitters", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE + for (input in list(.fmp_qss, .fmp_gss)) { + kind <- class(input)[[1L]] + res <- .fmp_fitRss(input) + expect_s4_class(res, .fmp_resultClass[[kind]]) + expect_equal(nrow(res), 1L, info = kind) + expect_equal(methodNames(res), "susie", info = kind) + # The result carries the build its summary statistics name. + expect_identical( + unique(unname(GenomeInfoDb::genome(res))), + "hg19", + info = kind ) - ) - expect_s4_class(res, "QtlFineMappingResult") - expect_equal(nrow(res), 1L) + } }) -test_that("fineMappingPipeline(QtlSumStats): un-QCd input rejected", { - ss <- .fmp_makeQtlSumStats(qc = FALSE) - expect_error( - fineMappingPipeline(ss, methods = "susie"), - "has no QC record" +test_that("fineMappingPipeline(*SumStats): un-QCd input rejected", { + unQcd <- list( + .fmp_makeQtlSumStats(qc = FALSE), + .fmp_makeGwasSumStats(qc = FALSE) ) + for (input in unQcd) { + expect_error( + fineMappingPipeline(input, methods = "susie"), + "has no QC record", + info = class(input)[[1L]] + ) + } }) test_that("fineMappingPipeline(QtlSumStats): empty selection rejected", { - ss <- .fmp_makeQtlSumStats() expect_error( - fineMappingPipeline(ss, methods = "susie", traitId = "ghost"), + fineMappingPipeline(.fmp_qss, 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"), + fineMappingPipeline(.fmp_qss, methods = "susie", contexts = "ghost"), "no study has: ghost" ) }) @@ -2362,54 +2263,75 @@ test_that("fineMappingPipeline(QtlSumStats): empty selection rejected", { # fineMappingPipeline(GwasSumStats) # =========================================================================== -test_that("fineMappingPipeline(GwasSumStats): runs end-to-end with mocked RSS fitters", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(GwasSumStats): a blockId gives no window", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( + regionOf <- function(blockId) { + gss <- GwasSumStats( + studyName = "G1", + entry = list(.fmp_makeSumstatsGr()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + blockId = blockId, + qcOptions = list(step1 = "ok") + ) + res <- suppressMessages(fineMappingPipeline( gss, methods = "susie", initializeWithSusieInf = FALSE - ) - ) - expect_s4_class(res, "GwasFineMappingResult") - expect_equal(nrow(res), 1L) - expect_setequal(methodNames(res), "susie") + )) + reg <- genomicRegion(res) + c(GenomicRanges::start(reg), GenomicRanges::end(reg)) + } + # A blockId is a name, however it is spelled, so the window is the + # entry's span; a window the caller means goes in `region`. + expect_equal(regionOf("chr1_50_600"), c(100L, 500L)) + expect_equal(regionOf("block1"), c(100L, 500L)) }) -test_that("fineMappingPipeline(GwasSumStats): opaque blockId, entry's span", { +test_that("fineMappingPipeline(GwasSumStats): a range keeps its origin", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - regionOf <- function(blockId) { + fitOver <- function(...) { gss <- GwasSumStats( studyName = "G1", entry = list(.fmp_makeSumstatsGr()), genome = "hg19", ldReference = .fmp_makeHandle(), - blockId = blockId, - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok"), + ... ) - res <- suppressMessages(fineMappingPipeline( + 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)) + # A window named in a blockId column gives the block its range and key. + named <- fitOver( + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(1L, 2000L), + blockId = "b1" + ) + ) + expect_identical(named$blockId, "b1") + expect_identical(as.character(genomicRegion(named)), "chr1:1-2000") + expect_true(named$regionGiven) + # Without one, the row keeps its seqname as its name, and its span bounds + # the block, computed. + bare <- fitOver() + expect_identical(bare$blockId, "chr1") + expect_identical(as.character(genomicRegion(bare)), "chr1:100-500") + expect_false(bare$regionGiven) }) test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { @@ -2439,7 +2361,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { entry = list(gr), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) captured <- new.env(parent = emptyenv()) captured$n <- "UNSET" @@ -2462,7 +2384,7 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { if (is.null(vids)) { vids <- snp_ids } - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(method = method), topLoci = data.frame( @@ -2492,23 +2414,28 @@ test_that("fineMappingPipeline(GwasSumStats): threads per-variant N", { # ---- PIP-screen graceful skip: a screened region -> empty result, not error ---- +# A collection whose rows QC audited as `audits` (one list per row). +.fmp_withAudits <- function(x, audits) { + x$qcAudit <- S4Vectors::SimpleList(audits) + x +} + # A GwasSumStats whose (single) entry was emptied by summaryStatsQc's PIP screen: -# 0-variant entry + qcInfo$entryAudit[[1]]$pipScreenSkipped = TRUE (+ reason). +# 0-variant entry + an audit with pipScreenSkipped = TRUE (+ reason). .fmp_makeScreenedGwas <- function( studyName = "G1", reason = "no signals above PIP threshold 0.025" ) { - GwasSumStats( + gss <- GwasSumStats( studyName = studyName, entry = list(GenomicRanges::GRanges()), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = list( - entryAudit = list(list( - pipScreenSkipped = TRUE, - pipScreenReason = reason - )) - ) + qcOptions = list(step1 = "ok") + ) + .fmp_withAudits( + gss, + list(list(pipScreenSkipped = TRUE, pipScreenReason = reason)) ) } @@ -2525,12 +2452,15 @@ 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))) + noReason <- .fmp_withAudits( + GwasSumStats( + studyName = "G1", + entry = list(GenomicRanges::GRanges()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + qcOptions = list(step1 = "ok") + ), + list(list(pipScreenSkipped = TRUE)) ) expect_message( fineMappingPipeline( @@ -2543,16 +2473,17 @@ test_that("fineMappingPipeline(GwasSumStats): a PIP-screened region yields an em }) test_that("fineMappingPipeline(GwasSumStats): mixed screened + real keeps only the real region", { - gss <- GwasSumStats( - studyName = c("Gskip", "Greal"), - entry = list(GenomicRanges::GRanges(), .fmp_makeSumstatsGr()), - genome = "hg19", - ldReference = .fmp_makeHandle(), - qcInfo = list( - entryAudit = list( - list(pipScreenSkipped = TRUE, pipScreenReason = "no signal"), - list() - ) + gss <- .fmp_withAudits( + GwasSumStats( + studyName = c("Gskip", "Greal"), + entry = list(GenomicRanges::GRanges(), .fmp_makeSumstatsGr()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + qcOptions = list(step1 = "ok") + ), + list( + list(pipScreenSkipped = TRUE, pipScreenReason = "no signal"), + list() ) ) local_mocked_bindings( @@ -2578,7 +2509,7 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even entry = list(GenomicRanges::GRanges()), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) res <- suppressMessages( fineMappingPipeline( @@ -2592,19 +2523,17 @@ test_that("fineMappingPipeline(GwasSumStats): a 0-variant entry is skipped even }) test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefully", { - qss <- QtlSumStats( - studyName = "Q1", - context = "c1", - trait = "t1", - entry = list(GenomicRanges::GRanges()), - genome = "hg19", - ldReference = .fmp_makeHandle(), - qcInfo = list( - entryAudit = list(list( - pipScreenSkipped = TRUE, - pipScreenReason = "no signal" - )) - ) + qss <- .fmp_withAudits( + QtlSumStats( + studyName = "Q1", + context = "c1", + trait = "t1", + entry = list(GenomicRanges::GRanges()), + genome = "hg19", + ldReference = .fmp_makeHandle(), + qcOptions = list(step1 = "ok") + ), + list(list(pipScreenSkipped = TRUE, pipScreenReason = "no signal")) ) res <- suppressMessages( fineMappingPipeline( @@ -2618,226 +2547,143 @@ test_that("fineMappingPipeline(QtlSumStats): a screened trait is skipped gracefu }) # ---- SER fallback (shared sumstat SuSiE-RSS path: GwasSumStats + QtlSumStats) ---- +# +# Both summary-statistics inputs reach the same SuSiE-RSS block, so each test +# runs it once per input kind. -test_that("fineMappingPipeline(GwasSumStats): serFallback + reliable R keeps multi-effect", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): serFallback keeps a reliable fit", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - sf <- susieFit(res, studyName = "G1", method = "susie") - # Multi-effect fit reported (payload keeps the multi tag, not the ser tag). - expect_equal(sf$payload$multiTag, "multi") - expect_false(sf$serFallbackUsed) - expect_false(sf$R_reliability_flag) - # keepFullFit="fallback": non-fallback region carries no retained fit. - expect_null(sf$multiEffectFit) + for (input in list(.fmp_gss, .fmp_qss)) { + kind <- class(input)[[1L]] + sf <- susieFit(.fmp_fitRss( + input, + SusieRssParam(serFallback = TRUE, rMismatch = "eb") + )) + # Multi-effect fit reported (payload keeps the multi tag, not the ser + # tag). + expect_equal(sf$payload$multiTag, "multi", info = kind) + expect_false(sf$serFallbackUsed, info = kind) + expect_false(sf$R_reliability_flag, info = kind) + # keepFullFit="fallback": non-fallback region carries no retained fit. + expect_null(sf$multiEffectFit, info = kind) + } }) -test_that("fineMappingPipeline(GwasSumStats): serFallback + unreliable R falls back to SER", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): unreliable R falls back to SER", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - sf <- susieFit(res, studyName = "G1", method = "susie") - # Reported result is the single-effect ser_model. - expect_equal(sf$payload$serTag, "ser") - expect_true(sf$serFallbackUsed) - expect_true(sf$R_reliability_flag) - # Fallback region retains the pre-fallback multi-effect fit. - expect_false(is.null(sf$multiEffectFit)) - expect_equal(sf$multiEffectFit$multiTag, "multi") + for (input in list(.fmp_gss, .fmp_qss)) { + kind <- class(input)[[1L]] + sf <- susieFit(.fmp_fitRss( + input, + SusieRssParam(serFallback = TRUE, rMismatch = "eb") + )) + # Reported result is the single-effect ser_model. + expect_equal(sf$payload$serTag, "ser", info = kind) + expect_true(sf$serFallbackUsed, info = kind) + expect_true(sf$R_reliability_flag, info = kind) + # Fallback region retains the pre-fallback multi-effect fit. + expect_false(is.null(sf$multiEffectFit), info = kind) + expect_equal(sf$multiEffectFit$multiTag, "multi", info = kind) + } }) -test_that("fineMappingPipeline(GwasSumStats): serFallback=FALSE default is behavior-preserving", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): serFallback=FALSE changes nothing", { + cap <- new.env(parent = emptyenv()) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE), + .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE, capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE - ) - ) - sf <- susieFit(res, studyName = "G1", method = "susie") - # No fallback even though flag=TRUE; multi-effect result kept. - expect_equal(sf$payload$multiTag, "multi") - # Feature off: the susieFit carries NO diagnostic fields (byte-identical to - # pre-change behavior). - expect_false("R_reliability_flag" %in% names(sf)) - expect_false("serFallbackUsed" %in% names(sf)) - expect_false("multiEffectFit" %in% names(sf)) + for (input in list(.fmp_gss, .fmp_qss)) { + kind <- class(input)[[1L]] + sf <- susieFit(.fmp_fitRss(input)) + # With serFallback off (the default), the shared block never fires the + # fallback nor forwards a non-default rFinite/rMismatch -- even though + # the mock flags the fit unreliable -- so the multi-effect result is + # kept and the fit carries NO diagnostic fields. + expect_null(cap$rFinite, info = kind) + expect_equal(cap$rMismatch, "none", info = kind) + expect_equal(sf$payload$multiTag, "multi", info = kind) + expect_false("R_reliability_flag" %in% names(sf), info = kind) + expect_false("serFallbackUsed" %in% names(sf), info = kind) + expect_false("multiEffectFit" %in% names(sf), info = kind) + } }) -test_that("fineMappingPipeline(GwasSumStats): rFinite/rMismatch forwarded; rFinite defaults to panel N", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): SusieRssParam reaches the fitter", { + # rFinite defaults to the LD-panel sample size (40 in .fmp_makeHandle) and + # an explicit one is forwarded verbatim; rMismatch -- eb_mix too, which + # susieR >= 0.16.6 takes -- and the susie_rss_control() settings pass + # through unrestricted, and with no control the fitter sees NULL. cap <- new.env(parent = emptyenv()) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap), + .fmFitSusieRss = .fmp_mockFitRssDiag(capture = cap), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - # rFinite defaulted to the LD-panel sample size (40 in .fmp_makeHandle). - expect_equal(cap$rFinite, 40L) - expect_equal(cap$rMismatch, "eb") - - # Explicit rFinite is forwarded verbatim. - cap2 <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap2), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( + control <- SusieRssControlOptions( + check_prior = TRUE, + mismatch_estimator = "map" + ) + for (input in list(.fmp_gss, .fmp_qss)) { + kind <- class(input)[[1L]] + .fmp_fitRss(input, SusieRssParam(serFallback = TRUE, rMismatch = "eb")) + expect_equal(cap$rFinite, 40L, info = kind) + expect_equal(cap$rMismatch, "eb", info = kind) + expect_null(cap$rssControl, info = kind) + .fmp_fitRss( + input, + SusieRssParam( serFallback = TRUE, rFinite = 12345, - rMismatch = "eb" - ) - ) - ) - expect_equal(cap2$rFinite, 12345) - - # eb_mix (susieR >= 0.16.6) is passed through to R_mismatch unrestricted. - cap3 <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap3), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb_mix" + rMismatch = "eb_mix", + control = control ) ) - ) - expect_equal(cap3$rMismatch, "eb_mix") - - # rssControl (susie_rss_control() settings) forwarded through to the fitter. - cap4 <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap4), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - control = SusieRssControlOptions( - check_prior = TRUE, - mismatch_estimator = "map" - ) - ) - ) - ) - expect_equal( - cap4$rssControl, - list(check_prior = TRUE, mismatch_estimator = "map") - ) - # default: no rssControl -> fitter sees NULL - cap5 <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap5), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE + expect_equal(cap$rFinite, 12345, info = kind) + expect_equal(cap$rMismatch, "eb_mix", info = kind) + expect_equal( + cap$rssControl, + list(check_prior = TRUE, mismatch_estimator = "map"), + info = kind ) - ) - expect_null(cap5$rssControl) + } }) -test_that("fineMappingPipeline(GwasSumStats): keepFullFit='all' retains fit on non-fallback region", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): keepFullFit='all' retains the fit", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - gss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb", - keepFullFit = "all" - ) - ) - ) - sf <- susieFit(res, studyName = "G1", method = "susie") - expect_false(is.null(sf$multiEffectFit)) - expect_equal(sf$multiEffectFit$multiTag, "multi") + keepAll <- SusieRssParam( + serFallback = TRUE, + rMismatch = "eb", + keepFullFit = "all" + ) + for (input in list(.fmp_gss, .fmp_qss)) { + kind <- class(input)[[1L]] + # A region that did not fall back still keeps its multi-effect fit. + sf <- susieFit(.fmp_fitRss(input, keepAll)) + expect_false(is.null(sf$multiEffectFit), info = kind) + expect_equal(sf$multiEffectFit$multiTag, "multi", info = kind) + } }) test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the susie fit", { - ss <- .fmp_makeQtlSumStats() cap <- new.env(parent = emptyenv()) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), @@ -2847,7 +2693,7 @@ test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the sus ) suppressMessages( fineMappingPipeline( - ss, + .fmp_qss, methods = "susie", initializeWithSusieInf = FALSE, credibleSetParam = CredibleSetParam( @@ -2863,7 +2709,6 @@ test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the sus }) test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L", { - ss <- .fmp_makeQtlSumStats() cap <- new.env(parent = emptyenv()) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), @@ -2873,7 +2718,7 @@ test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L" ) suppressMessages( fineMappingPipeline( - ss, + .fmp_qss, methods = list(susie = list(L = 7L)), initializeWithSusieInf = FALSE, credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L) @@ -2882,229 +2727,28 @@ test_that("fineMappingPipeline(QtlSumStats): per-method L beats the top-level L" expect_equal(cap$userArgs$L, 7L) }) -test_that("fineMappingPipeline(QtlSumStats): serFallback=FALSE default leaves the QTL path unchanged", { - ss <- .fmp_makeQtlSumStats() - cap <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE, capture = cap), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE - ) - ) - expect_s4_class(res, "QtlFineMappingResult") - # With serFallback off (the default), the shared block never fires the - # fallback nor forwards a non-default rFinite/rMismatch -- even though the - # mock flags the fit unreliable -- so the result is byte-identical to before. - expect_null(cap$rFinite) - expect_equal(cap$rMismatch, "none") - sf <- susieFit( - res, - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie" - ) - expect_false("R_reliability_flag" %in% names(sf)) - expect_false("serFallbackUsed" %in% names(sf)) - expect_false("multiEffectFit" %in% names(sf)) -}) - -test_that("fineMappingPipeline(QtlSumStats): serFallback + reliable R keeps multi-effect", { - ss <- .fmp_makeQtlSumStats() - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - sf <- susieFit( - res, - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie" - ) - # Multi-effect fit reported (payload keeps the multi tag, not the ser tag). - expect_equal(sf$payload$multiTag, "multi") - expect_false(sf$serFallbackUsed) - expect_false(sf$R_reliability_flag) - # keepFullFit="fallback": non-fallback region carries no retained fit. - expect_null(sf$multiEffectFit) -}) - -test_that("fineMappingPipeline(QtlSumStats): serFallback + unreliable R falls back to SER", { - ss <- .fmp_makeQtlSumStats() - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = TRUE), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - sf <- susieFit( - res, - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie" - ) - # Reported result is the single-effect ser_model. - expect_equal(sf$payload$serTag, "ser") - expect_true(sf$serFallbackUsed) - expect_true(sf$R_reliability_flag) - # Fallback region retains the pre-fallback multi-effect fit. - expect_false(is.null(sf$multiEffectFit)) - expect_equal(sf$multiEffectFit$multiTag, "multi") -}) - -test_that("fineMappingPipeline(QtlSumStats): rFinite/rMismatch forwarded; rFinite defaults to panel N", { - ss <- .fmp_makeQtlSumStats() - cap <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb" - ) - ) - ) - # rFinite defaulted to the LD-panel sample size (40 in .fmp_makeHandle). - expect_equal(cap$rFinite, 40L) - expect_equal(cap$rMismatch, "eb") - - # Explicit rFinite is forwarded verbatim. - cap2 <- new.env(parent = emptyenv()) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE, capture = cap2), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rFinite = 12345, - rMismatch = "eb" - ) - ) - ) - expect_equal(cap2$rFinite, 12345) -}) - -test_that("fineMappingPipeline(QtlSumStats): keepFullFit='all' retains fit on non-fallback region", { - ss <- .fmp_makeQtlSumStats() - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRssDiag(flag = FALSE), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susie", - initializeWithSusieInf = FALSE, - susieRssParam = SusieRssParam( - serFallback = TRUE, - rMismatch = "eb", - keepFullFit = "all" - ) - ) - ) - sf <- susieFit( - res, - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie" - ) - expect_false(is.null(sf$multiEffectFit)) - expect_equal(sf$multiEffectFit$multiTag, "multi") -}) - -test_that("fineMappingPipeline(GwasSumStats): un-QCd input rejected", { - gss <- .fmp_makeGwasSumStats(qc = FALSE) - expect_error( - fineMappingPipeline(gss, methods = "susie"), - "has no QC record" - ) -}) - test_that("fineMappingPipeline(GwasSumStats): non-RSS family rejected by capability check", { - gss <- .fmp_makeGwasSumStats() expect_error( - fineMappingPipeline(gss, methods = "fsusie"), + fineMappingPipeline(.fmp_gss, methods = "fsusie"), "not supported on GwasSumStats" ) }) # ---- ser (LD-free single-effect regression); sumstat-only, not GWAS-only ---- -test_that("fineMappingPipeline(QtlSumStats): ser dispatches via .fmFitSusieSer", { - ss <- .fmp_makeQtlSumStats() +test_that("fineMappingPipeline(*SumStats): ser runs via .fmFitSusieSer", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieSer = .fmp_mockFitSer(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages(fineMappingPipeline(ss, methods = "ser")) - expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(methodNames(res), "ser") -}) - -test_that("fineMappingPipeline(GwasSumStats): ser dispatches via .fmFitSusieSer", { - gss <- .fmp_makeGwasSumStats() - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieSer = .fmp_mockFitSer(), - .fmPostprocessOne = .fmp_mockPostprocess(), - .package = "pecotmr" - ) - res <- suppressMessages(fineMappingPipeline(gss, methods = "ser")) - expect_s4_class(res, "GwasFineMappingResult") - expect_setequal(methodNames(res), "ser") + for (input in list(.fmp_qss, .fmp_gss)) { + kind <- class(input)[[1L]] + res <- suppressMessages(fineMappingPipeline(input, methods = "ser")) + expect_s4_class(res, .fmp_resultClass[[kind]]) + expect_equal(methodNames(res), "ser", info = kind) + } }) test_that("ser is sumstat-only: rejected on QtlDataset, allowed on all sumstat kinds", { @@ -3143,20 +2787,12 @@ test_that("fineMappingPipeline(ANY): unsupported input class errors", { }) # =========================================================================== -# Cache hit short-circuits the fit -# =========================================================================== - -# =========================================================================== -# .fmFitSusieIndiv / .fmFitSusieRss — chained-init and branch coverage -# =========================================================================== - -# =========================================================================== -# QtlSumStats: empty selection, mvsusie single-context rejection, cache hits +# QtlSumStats: mvsusie single-context rejection and auto-detection, cache hits # =========================================================================== .fmp_makeMultiCtxQtlSumStats <- function() { - # Multi-row QtlSumStats: 2 contexts x 1 trait so the test can filter to - # a single context and exercise both selRows filters. + # Multi-row QtlSumStats: 2 contexts x 1 trait, the shape a cross-context + # joint fit takes. e1 <- .fmp_makeSumstatsGr() e2 <- .fmp_makeSumstatsGr() QtlSumStats( @@ -3166,22 +2802,11 @@ test_that("fineMappingPipeline(ANY): unsupported input class errors", { entry = list(e1, e2), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) } -test_that("fineMappingPipeline(QtlSumStats): traitId filter that selects no rows errors", { - ss <- .fmp_makeMultiCtxQtlSumStats() - expect_error( - fineMappingPipeline(ss, methods = "susie", traitId = "ghost"), - "no entries matched" - ) -}) - -test_that("fineMappingPipeline( - QtlSumStats): mvsusie rejected when every (study, - trait -) has only one context", { +test_that("fineMappingPipeline(QtlSumStats): mvsusie needs two contexts", { # Build a single-context-per-(study, trait) collection. Mvsusie requires # at least two contexts per (study, trait) group. ss <- QtlSumStats( @@ -3191,7 +2816,7 @@ test_that("fineMappingPipeline( entry = list(.fmp_makeSumstatsGr(), .fmp_makeSumstatsGr()), genome = "hg19", ldReference = .fmp_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) expect_error( fineMappingPipeline(ss, methods = "mvsusie"), @@ -3199,10 +2824,7 @@ test_that("fineMappingPipeline( ) }) -test_that("fineMappingPipeline( - QtlSumStats): mvsusie auto-detection fits cross-context per (study, - trait -)", { +test_that("fineMappingPipeline(QtlSumStats): mvsusie auto-joins contexts", { # Multi-context (c1, c2) single-trait collection: mvsusie without an explicit # jointSpecification routes through the joint engine -> per-context rows that # share the cross-context RSS fit, each tagged with the co-fit membership. @@ -3228,8 +2850,8 @@ test_that("fineMappingPipeline( }) test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fitter", { - ss <- .fmp_makeQtlSumStats() - cachedEntry <- fineMappingRow( + ss <- .fmp_qss + cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), susieFit = list(token = "susie_cached"), topLoci = data.frame( @@ -3273,8 +2895,8 @@ test_that("fineMappingPipeline(QtlSumStats): cache hit short-circuits the RSS fi # =========================================================================== test_that("fineMappingPipeline(GwasSumStats): cache hit short-circuits the RSS fitter", { - gss <- .fmp_makeGwasSumStats() - cachedEntry <- fineMappingRow( + gss <- .fmp_gss + cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), susieFit = list(token = "susie_cached"), topLoci = data.frame( @@ -3320,8 +2942,8 @@ test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingR # When `fineMappingResult` is a QtlFineMappingResult the GwasSumStats # method's cache-lookup branch should treat it as a cache miss and # still invoke the RSS fitter. - gss <- .fmp_makeGwasSumStats() - cachedEntry <- fineMappingRow( + gss <- .fmp_gss + cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:5)), susieFit = list(token = "susie_cached"), topLoci = data.frame( @@ -3360,9 +2982,9 @@ test_that("fineMappingPipeline(GwasSumStats): wrong-shape cache (QtlFineMappingR }) test_that("fineMappingPipeline(QtlDataset): cache hit avoids the fitter", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA # Build a cache that already has the (study1, brain, ENSG_A, susie) row. - cachedEntry <- fineMappingRow( + cachedEntry <- FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:3)), susieFit = list(token = "susie_cached"), topLoci = data.frame( @@ -3401,87 +3023,11 @@ test_that("fineMappingPipeline(QtlDataset): cache hit avoids the fitter", { expect_equal(nrow(res), 1L) }) - -context("univariate_pipeline") - -# =========================================================================== -# Post-S4-refactor cleanup -# --------------------------------------------------------------------------- -# The S4 refactor removed `univariateAnalysisPipeline()`, -# `rssAnalysisPipeline()`, `loadStudyLd()`, `loadRssData()`, and -# `rssBasicQc()` as functional pipelines. They are now `.Deprecated()` -# no-ops that return `NULL` invisibly. The `QcResult` / -# `FineMappingResult` classes and `regionDataToSusieRssInput()` helper -# were also removed. Their replacements live behind a different S4 API -# (`fineMappingPipeline()` dispatched on `GwasSumStats` / `QtlSumStats` / -# `QtlDataset`, `summaryStatsQc()`, `fineMappingRow()`) with different -# signatures and contracts, so the legacy mocked pipeline tests cannot -# be ported in a meaningful way and have been removed. -# -# What survives in this file: -# * Deprecation no-op checks for the removed public wrappers. -# * Tests for `resolveLdInput()`, which is still a live internal helper -# in `dentistQc.R` with an unchanged signature. -# =========================================================================== - -# =========================================================================== -# resolveLdInput (still-live internal helper in dentistQc.R) -# =========================================================================== - -test_that("resolveLdInput errors when both R and X are NULL", { - expect_error( - pecotmr:::resolveLdInput(R = NULL, X = NULL), - "Either R .* or X .* must be provided" - ) -}) - -test_that("resolveLdInput errors when both R and X are provided", { - R <- diag(5) - X <- matrix(rnorm(50), 10, 5) - expect_error( - pecotmr:::resolveLdInput(R = R, X = X), - "Provide either R or X, not both" - ) -}) - -test_that("resolveLdInput with R returns R unchanged", { - R <- diag(5) - result <- pecotmr:::resolveLdInput(R = R, nSample = 100) - expect_equal(result$R, R) - expect_equal(result$nSample, 100) -}) - -test_that("resolveLdInput with X computes LD and infers nSample", { - set.seed(42) - X <- matrix(rbinom(200, 2, 0.3), 20, 10) - result <- pecotmr:::resolveLdInput(X = X) - expect_equal(nrow(result$R), 10) - expect_equal(ncol(result$R), 10) - expect_equal(result$nSample, 20) -}) - -test_that("resolveLdInput errors when nSample required but missing", { - R <- diag(5) - expect_error( - pecotmr:::resolveLdInput(R = R, needNSample = TRUE), - "nSample is required" - ) -}) - -test_that("resolveLdInput does not error when nSample not needed", { - R <- diag(5) - result <- pecotmr:::resolveLdInput(R = R, needNSample = FALSE) - expect_equal(result$R, R) - expect_null(result$nSample) -}) # =========================================================================== # Residualization settings propagation # =========================================================================== -# These used to be four loose flags scraped off the call stack by -# .resPickFlags() (sys.frames() + get(envir = )), then four translated -# argument names via .resArgsFor(). The accessors now take the bundle -# itself, so there is no translation left to test -- only that the bundle -# travels intact. +# The accessors take the ResidualizationParam bundle itself, so there is no +# translation to test -- only that the bundle travels intact. test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { capturedGeno <- NULL @@ -3492,11 +3038,11 @@ test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { } fakePheno <- function(x, ...) { capturedPheno <<- list(...) - matrix(0, 0, 0) + list(c1 = matrix(0, 0, 0)) } local_mocked_bindings( - residualizedGenotypes = fakeGeno, - residualizedPhenotypes = fakePheno, + .qtlResidualizedGenotypes = fakeGeno, + .qtlResidualizedPhenotypes = fakePheno, .package = "pecotmr" ) res <- ResidualizationParam( @@ -3506,7 +3052,12 @@ 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", residualizationParam = res) + pecotmr:::.fmResidGeno( + NULL, + contexts = "c1", + residualizationParam = res, + genotypeFilter = pecotmr:::.qtlResolveFilter() + ) pecotmr:::.fmResidPheno(NULL, contexts = "c1", residualizationParam = res) for (captured in list(capturedGeno, capturedPheno)) { got <- captured$residualizationParam @@ -3520,9 +3071,9 @@ test_that(".fmResidGeno / .fmResidPheno forward the bundle to the accessors", { test_that("an absent bundle becomes the constructor's own defaults", { captured <- NULL local_mocked_bindings( - residualizedPhenotypes = function(x, ...) { + .qtlResidualizedPhenotypes = function(x, ...) { captured <<- list(...) - matrix(0, 0, 0) + list(c1 = matrix(0, 0, 0)) }, .package = "pecotmr" ) @@ -3532,49 +3083,6 @@ test_that("an absent bundle becomes the constructor's own defaults", { expect_length(captured$residualizationParam, 0L) }) -# =========================================================================== -# Removed during the post-S4-refactor cleanup (for traceability) -# --------------------------------------------------------------------------- -# univariateAnalysisPipeline input-validation tests (12): -# * X non-matrix / non-numeric / Y non-numeric / multi-column Y / -# single-column Y / X-Y row mismatch / maf length mismatch / -# maf out of bounds / invalid xScalar / wrong-length xScalar / -# non-numeric yScalar / non-positive L / non-positive lGreedy. -# univariateAnalysisPipeline functional tests (4): -# * minimal valid input; twasWeights = TRUE; respects xScalar; -# cvFolds = 0. -# univariateAnalysisPipeline mocked-pipeline tests (16): -# * pip_cutoff_to_skip branch (3); LD reference filtering (2); -# filter_X branch (2); main susie + post-processing (4); -# TWAS weights (4); coverage forwarding (2); combined LD + -# filter_X (1); null imiss/maf cutoffs (1). -# univariateAnalysisPipeline af/maf single-source tests (6): -# * af supplied (no maf); maf supplied (no af); both disagreeing; -# neither with mafCutoff errors; neither without mafCutoff runs; -# af-derived MAF parity with explicit maf. -# rssAnalysisPipeline tests (~21): -# * input-file validation; empty sumstats branches; pip_cutoff_to_skip -# branches; full QC + imputation + fine-mapping; method-name -# conventions (NO_QC / SLALOM / DENTIST / RAISS); outlierNumber -# plumbing; finemappingMethod = NULL skip; ldMismatchQcMethod = NULL; -# impute = FALSE; diagnostics branches (BCR + SER re-analysis); -# finemappingOpts passthrough; mafCutoff (af single source); -# finemapping-defaults passthrough; X-as-LD genotype path; -# mixture-LD passthrough. -# regionDataToSusieRssInput tests (3): -# * correlation-backed input; genotype-backed input; rejects -# default rownames as variant IDs. -# loadStudyLd tests (2): -# * single path returns loadLdMatrix output unchanged; comma-separated -# paths build a mixture LdData with a list of genotype handles. -# -# Replacement APIs (do NOT speculatively port — that is out of scope for -# this cleanup): `fineMappingPipeline()` dispatched on `GwasSumStats` / -# `QtlSumStats` / `QtlDataset`; `summaryStatsQc()` (returns a SumStats -# with `qcInfo()` populated); `fineMappingRow(variantIds, ...)`; -# `result$finemappingEntry` (was `result$finemappingResult`). -# =========================================================================== - # =========================================================================== # Multi-region / jointRegions (P3) # =========================================================================== @@ -3599,7 +3107,7 @@ test_that(".fmMergeEntries concatenates variants, renumbers CS, lists susieFit", # Ids must encode coordinates: the merge now emits a row payload, whose # element is built from the range and alleles the id renders. mk <- function(vids, cs95, fit) { - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = fit, topLoci = data.frame( @@ -3625,10 +3133,11 @@ test_that(".fmMergeEntries concatenates variants, renumbers CS, lists susieFit", expect_equal(names(fit), c("region1", "region2")) }) -test_that(".fmMergeEntries returns a single entry unchanged", { +test_that(".fmMergeEntries: no entries -> NULL; one comes back unchanged", { + expect_null(pecotmr:::.fmMergeEntries(list(NULL, NULL))) # Ids must encode coordinates now: the payload builds its element from the # range and alleles the id renders. - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5) @@ -3644,7 +3153,7 @@ test_that(".fmMergeEntries renumbers past a region with no cs column", { if (!is.null(cs95)) { tl$cs_95 <- cs95 } - fineMappingRow(variantIds = vids, susieFit = NULL, topLoci = tl) + FineMappingRow(variantIds = vids, susieFit = NULL, topLoci = tl) } m <- pecotmr:::.fmMergeEntries(list( mk("chr1:100:A:G", "susie_1"), @@ -3655,8 +3164,22 @@ test_that(".fmMergeEntries renumbers past a region with no cs column", { expect_equal(tl$cs_95, c("susie_1", NA, "susie_2")) }) +test_that("fineMappingPipeline(QtlDataset): region is a GRanges", { + # Given in R, a window is a GRanges; a string or a table is refused rather + # than read, so its base is never in doubt. + expect_error( + fineMappingPipeline( + .fmp_qdAB, + methods = "susie", + region = "chr1:1-600" + ), + "`region` must be a GRanges (got character)", + fixed = TRUE + ) +}) + test_that("fineMappingPipeline(QtlDataset): region + cisWindow is rejected", { - qd <- .fmp_makeQtlDataset() + qd <- .fmp_qdAB expect_error( fineMappingPipeline( qd, @@ -3669,10 +3192,7 @@ test_that("fineMappingPipeline(QtlDataset): region + cisWindow is rejected", { }) test_that("fineMappingPipeline(QtlDataset): jointRegions=FALSE merges per-region fits", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -3705,7 +3225,7 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=FALSE merges per-region }) test_that("fineMappingPipeline(QtlDataset): jointRegions=TRUE fits one concatenated block", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -3737,10 +3257,7 @@ test_that("fineMappingPipeline(QtlDataset): jointRegions=TRUE fits one concatena }) test_that("fineMappingPipeline(QtlDataset): mvsusie jointRegions=FALSE merges per-region fits", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3774,10 +3291,7 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie jointRegions=FALSE merges pe }) test_that("fineMappingPipeline(QtlDataset): fsusie jointRegions=FALSE merges per-region fits", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3809,10 +3323,9 @@ test_that("fineMappingPipeline(QtlDataset): fsusie jointRegions=FALSE merges per }) test_that("fineMappingPipeline(QtlDataset): jointSpec + jointRegions=FALSE merges per region", { - qd <- .fmp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) + # One trait: the cross-context joint and the per-region merge are what is + # tested, and each further trait only repeats them. + qd <- .fmp_qdTwoCtxA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmPostprocessOne = .fmp_mockPostprocess(), @@ -3830,15 +3343,15 @@ test_that("fineMappingPipeline(QtlDataset): jointSpec + jointRegions=FALSE merge res <- suppressMessages(fineMappingPipeline( qd, methods = "mvsusie", - traitId = c("ENSG_A", "ENSG_B"), + traitId = "ENSG_A", region = regions, jointRegions = FALSE, jointSpecification = "context" )) expect_s4_class(res, "QtlFineMappingResult") - # cross-context joint -> per-context rows (2 contexts x 2 traits = 4), each - # merged across the 2 regions. - expect_equal(nrow(res), 4L) + # cross-context joint -> one row per context, each merged across the 2 + # regions. + expect_equal(nrow(res), 2L) expect_setequal(as.character(res$context), c("brain", "liver")) fit <- susieFit( res, @@ -3871,7 +3384,7 @@ test_that(".fmCacheLookupGwas: NULL / non-GwasFineMappingResult -> NULL", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -3899,7 +3412,7 @@ test_that(".fmBuildMvsusiePriorCv: NULL CV -> NULL; NULL fold fits are skipped", c("c1", "c2") ) expect_equal(out[["1"]], "PRIOR") - expect_null(out[["2"]]) # NULL fold -> next (831) + expect_null(out[["2"]]) # a NULL fold fit is skipped }) test_that(".fmFoldFitAt finds a fold's fit by name, else by position", { @@ -3913,84 +3426,31 @@ test_that(".fmFoldFitAt finds a fold's fit by name, else by position", { 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 - expect_null(pecotmr:::.fmTopPcScores( - cbind(a = rep(1, 4), b = rnorm(4)), - 2L - )) # < 2 nonzero-var - set.seed(1) - Y <- matrix( - rnorm(20), - 10, - 2, - dimnames = list(paste0("s", 1:10), c("t1", "t2")) - ) - sc <- pecotmr:::.fmTopPcScores(Y, 2L) - expect_equal(dim(sc), c(10L, 2L)) - expect_equal(colnames(sc), c("topPC1", "topPC2")) -}) - -test_that(".fmMergeEntries: empty -> NULL; merges per-region entries + relabels CS", { - expect_null(pecotmr:::.fmMergeEntries(list(NULL, NULL))) - e1 <- fineMappingRow( - "chr1:100:A:G", - list(a = 1), - data.frame(variant_id = "chr1:100:A:G", pip = 0.9, cs_95 = "susie_1") - ) - e2 <- fineMappingRow( - "chr1:200:A:G", - list(b = 2), - data.frame(variant_id = "chr1:200:A:G", pip = 0.8, cs_95 = "susie_1") - ) - m <- pecotmr:::.fmMergeEntries(list(e1, e2)) - expect_equal( - pecotmr:::.fmrPartsVariantIds(m), - c("chr1:100:A:G", "chr1:200:A:G") - ) - # region2's CS is relabelled - expect_equal( - pecotmr:::.fmrPartsTopLoci(m)$cs_95, - c("susie_1", "susie_2") - ) - expect_equal( - names(pecotmr:::.fmrPartsSusieFit(m)), - c("region1", "region2") - ) -}) - test_that(".fmTwasMethodKey: bare token without adapter returned unchanged", { - expect_equal(pecotmr:::.fmTwasMethodKey("lasso"), "lasso") # no adapter (1170) + expect_equal(pecotmr:::.fmTwasMethodKey("lasso"), "lasso") # no adapter expect_equal(pecotmr:::.fmTwasMethodKey("susie"), "susie") # adapter -> stripped }) -test_that(".cvMetricRow: < 3 usable predictions -> all-NA row", { - expect_true(all(is.na(pecotmr:::.cvMetricRow(c(1, 2), c(1, 2))))) # < 3 (1182) - ok <- pecotmr:::.cvMetricRow(c(1, 2, 3, 4, 5), c(1.1, 2, 2.9, 4, 5)) - expect_false(is.na(ok[["rsq"]])) -}) - test_that(".fmSliceCv: NULL cv or missing predicted key -> NULL", { - expect_null(pecotmr:::.fmSliceCv(NULL, "susie")) # 1323 + expect_null(pecotmr:::.fmSliceCv(NULL, "susie")) cv <- list( samplePartition = NULL, prediction = list(enet_predicted = matrix(0, 1, 1)), performance = list(enet_performance = matrix(0, 1, 6)) ) - expect_null(pecotmr:::.fmSliceCv(cv, "susie")) # pk absent (1327) + expect_null(pecotmr:::.fmSliceCv(cv, "susie")) # no susie_predicted key expect_true( "enet_predicted" %in% names(pecotmr:::.fmSliceCv(cv, "enet")$prediction) ) }) test_that(".fmAttachCv: NULL entry or NULL cvResult returns the entry unchanged", { - e <- fineMappingRow( + e <- FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) ) - expect_identical(pecotmr:::.fmAttachCv(e, NULL), e) # 1336 + expect_identical(pecotmr:::.fmAttachCv(e, NULL), e) expect_null(pecotmr:::.fmAttachCv(NULL, list(x = 1))) expect_equal( pecotmr:::.fmrPartsCvResult( @@ -4001,27 +3461,17 @@ test_that(".fmAttachCv: NULL entry or NULL cvResult returns the entry unchanged" }) # ---- jointSpec dispatch branches in the QtlSumStats / MultiStudy methods ----- -# (dispatchers mocked; the real joint fitting is covered in test_jointSpecification.R) - -test_that(".fmTopPcScores: nPCs = 0 -> k < 1 -> NULL", { - set.seed(3) - Y <- matrix( - rnorm(20), - 10, - 2, - dimnames = list(paste0("s", 1:10), c("t1", "t2")) - ) - expect_null(pecotmr:::.fmTopPcScores(Y, 0L)) # k < 1 (858) -}) +# (dispatchers mocked; the real joint fitting is covered in +# test_jointSpecification.R) test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec returns the joint result", { - ss <- .fmp_makeQtlSumStats() + ss <- .fmp_qss jr <- QtlFineMappingResult( studyName = "Q1", context = "c1", trait = "t1", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4039,19 +3489,19 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec returns the ) ) expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(as.character(res$method), "mvsusie") # 1843-1857 + expect_setequal(as.character(res$method), "mvsusie") }) 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() + ss <- .fmp_qss jr <- QtlFineMappingResult( studyName = "Q1", context = "c1", trait = "t1", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4090,14 +3540,13 @@ test_that("fineMappingPipeline(QtlSumStats): no auto-joint fit is an error", { }) test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec with no fits -> error", { - ss <- .fmp_makeQtlSumStats() local_mocked_bindings( .fmDispatchJointSpecsQtlSumStats = function(...) NULL, .package = "pecotmr" ) expect_error( suppressMessages(fineMappingPipeline( - ss, + .fmp_qss, methods = "mvsusie", jointSpecification = "context" )), @@ -4105,21 +3554,12 @@ test_that("fineMappingPipeline(QtlSumStats): mvsusie-only jointSpec with no fits ) }) -.fmp_makeMultiStudy <- function() { - MultiStudyQtlDataset( - qtlDatasets = list( - study1 = .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - ), - sumStats = .fmp_makeQtlSumStats() - ) -} - test_that("MultiStudyQtlDataset forwards the mvsusie prior settings", { # `mrmashPrior` and `dataDrivenPriorWeightsCutoff` configure the mvsusie # data-driven reweighted prior. They used to reach ONLY jointCfg (the # cross-study joint phase); the per-study config omitted them, so every # per-study recursion silently refit mr.mash and used the 1e-10 cutoff. - mt <- .fmp_makeMultiStudy() + mt <- .fmp_msqd seen <- new.env(parent = emptyenv()) seen$perStudy <- NULL seen$sumStats <- NULL @@ -4152,26 +3592,58 @@ test_that("MultiStudyQtlDataset forwards the mvsusie prior settings", { } }) +test_that("fineMappingPipeline(MSQD) lays cisWindow on its sumstats", { + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + res <- suppressMessages(fineMappingPipeline( + .fmp_msqd, + methods = "susie", + cisWindow = 100L, + initializeWithSusieInf = FALSE + )) + fromSumStats <- which(res$study == "Q1") + expect_identical( + as.character(genomicRegion(res)[fromSumStats]), + "chr1:200-400" + ) + # A summary-statistics study without a trait position is an error, as it + # is on its own. + bare <- MultiStudyQtlDataset( + qtlDatasets = list(study1 = .fmp_qdA), + sumStats = .fmp_qss + ) + expect_error( + fineMappingPipeline(bare, methods = "susie", cisWindow = 100L), + "fineMappingPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) +}) + test_that("fineMappingPipeline(MultiStudyQtlDataset): region + cisWindow is rejected", { expect_error( fineMappingPipeline( - .fmp_makeMultiStudy(), + .fmp_msqd, methods = "mvsusie", region = GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 100)), cisWindow = 1000L ), "specify either" - ) # 1694 + ) }) test_that("fineMappingPipeline(MultiStudyQtlDataset): mvsusie-only jointSpec returns the joint result", { - mt <- .fmp_makeMultiStudy() + mt <- .fmp_msqd jr <- QtlFineMappingResult( studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4189,19 +3661,19 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): mvsusie-only jointSpec ret ) ) expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(as.character(res$method), "mvsusie") # 1709-1726 + expect_setequal(as.character(res$method), "mvsusie") }) 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() + mt <- .fmp_msqd jr <- QtlFineMappingResult( studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4230,7 +3702,7 @@ test_that("fineMappingPipeline(MultiStudy): joint spec, rest per component", { 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() + mt <- .fmp_msqd local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -4259,16 +3731,45 @@ test_that("fineMappingPipeline(MultiStudy): an unselected component sits out", { expect_setequal(as.character(studyOnly$study), "study1") }) +test_that("fineMappingPipeline(MultiStudy): trait selection skips a study", { + # A trait vector applies to every component too: one carrying none of + # the traits sits out, and the run is refused only when none carries any. + mt <- .fmp_msqd + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + fit <- function(traitId) { + suppressMessages(fineMappingPipeline( + mt, + methods = "susie", + traitId = traitId, + cisWindow = 1000L, + initializeWithSusieInf = FALSE + )) + } + expect_setequal(as.character(fit("t1")$study), "Q1") + expect_setequal(as.character(fit("ENSG_A")$study), "study1") + expect_error( + fit("absent"), + "fineMappingPipeline(MultiStudyQtlDataset): no traits selected.", + fixed = TRUE + ) +}) + 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() + mt <- .fmp_msqd jr <- QtlFineMappingResult( studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4396,7 +3897,7 @@ test_that(".fmPostprocessOne wraps a fit into a FineMappingRow", { postprocessFinemappingFits = function(...) list(x = 1), formatFinemappingOutput = function(post, primaryMethod, ...) { list( - finemappingEntry = fineMappingRow( + finemappingEntry = FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.5) @@ -4441,11 +3942,26 @@ test_that(".fmPostprocessOne errors when output carries no FineMappingRow", { ) }) -test_that(".fmWeightsCv covers per-fold prior, NULL-weights, and no-overlap branches", { - # mvPriorCv supplies a prior for fold "1" only: fold 1 takes the per-fold - # prior (else-branch) and returns weights whose rownames don't overlap the - # test columns (no-common `next`); fold 2 has no prior, so .fmFoldWeights - # returns NULL (NULL-weights `next`). +test_that(".fmWeightsCv: fold prior else mvPrior; weightless folds give NA", { + # Three folds of ten. Fold 1 has its own prior in mvPriorCv and weights + # (all 1) on the test variants; fold 2 has its own prior but its fit + # returns no weights; fold 3 has no prior of its own, so it takes the + # full-data mvPrior, and its weights share no variant with the test + # genotypes. Each fold fit records the prior it was handed. + set.seed(3) + X <- matrix( + rbinom(60, 2, 0.4), + 30, + 2, + dimnames = list(str_c("s", 1:30), c("chr1:100:A:G", "chr1:200:A:G")) + ) + Y <- matrix(rnorm(60), 30, 2, dimnames = list(rownames(X), c("c1", "c2"))) + sp <- data.frame(Sample = rownames(X), Fold = rep(1:3, each = 10)) + fullPrior <- list(priorVariance = diag(2) * 3) + foldPriors <- list( + "1" = list(priorVariance = diag(2)), + "2" = list(priorVariance = diag(2) * 2) + ) local_mocked_bindings( .fmFoldWeights = function( token, @@ -4454,77 +3970,71 @@ test_that(".fmWeightsCv covers per-fold prior, NULL-weights, and no-overlap bran coverage, userArgs, pos, - mvPrior - ) { - if (is.null(mvPrior)) { - return(NULL) - } - matrix(0.5, 1L, 1L, dimnames = list("not_a_variant", NULL)) - }, - .package = "pecotmr" - ) - set.seed(3) - X <- matrix( - rbinom(40, 2, 0.4), - 20, - 2, - dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) - ) - Y <- matrix(rnorm(40), 20, 2, dimnames = list(rownames(X), c("c1", "c2"))) - cv <- pecotmr:::.fmWeightsCv( - X, - Y, - tokens = "mvsusie", - methodArgs = list(mvsusie = list()), - fold = 2L, - coverage = 0.95, - verbose = 0, - mvPriorCv = list("1" = list(priorVariance = diag(2))) - ) - expect_named( - cv, - c("samplePartition", "prediction", "performance", "foldFits") - ) -}) - -test_that("fineMappingPipeline(QtlSumStats): susieInf RSS chain (mocked)", { - ss <- .fmp_makeQtlSumStats() - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieRss = .fmp_mockFitRss(), - .fmPostprocessOne = .fmp_mockPostprocess(), + mvPrior + ) { + trained <- sp$Fold[is_in(sp$Sample, rownames(Xtr))] + heldOut <- setdiff(sp$Fold, trained) + if (heldOut == 2L) { + return(NULL) + } + vars <- if (heldOut == 1L) colnames(Xtr) else "not_a_variant" + W <- matrix(1, length(vars), ncol(Ytr), dimnames = list(vars, NULL)) + `attr<-`(W, "fit", list(prior = mvPrior)) + }, .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - ss, - methods = "susieInf", - initializeWithSusieInf = FALSE, - verbose = 1 - ) + cv <- pecotmr:::.fmWeightsCv( + X, + Y, + tokens = "mvsusie", + methodArgs = list(mvsusie = list()), + fold = 3L, + samplePartition = sp, + verbose = 0, + mvPrior = fullPrior, + mvPriorCv = foldPriors + ) + # A fold takes its own prior when mvPriorCv has one, else mvPrior. + expect_identical(cv$foldFits$fold_1$mvsusie$prior, foldPriors[["1"]]) + expect_identical(cv$foldFits$fold_3$mvsusie$prior, fullPrior) + # A fold whose fit returns no weights keeps no fit either. + expect_length(cv$foldFits$fold_2, 0L) + # Only fold 1 predicts: X %*% W, the dosage row sums. NULL weights (fold + # 2) and weights on no test variant (fold 3) leave their samples NA ... + pred <- cv$prediction[["mvsusie_predicted"]] + f1 <- sp$Sample[sp$Fold == 1L] + expect_equal( + pred[f1, ], + cbind(c1 = rowSums(X[f1, ]), c2 = rowSums(X[f1, ])) + ) + expect_true(all(is.na(pred[!is_in(rownames(pred), f1), ]))) + # ... and those samples are left out of the score, not counted. + expect_equal( + cv$performance[["mvsusie_performance"]][, "corr"], + drop(cor(Y[f1, ], rowSums(X[f1, ]))) ) - expect_s4_class(res, "QtlFineMappingResult") - expect_setequal(as.character(res$method), "susieInf") }) -test_that("fineMappingPipeline(GwasSumStats): susieInf RSS chain (mocked)", { - gss <- .fmp_makeGwasSumStats() +test_that("fineMappingPipeline(*SumStats): susieInf RSS chain (mocked)", { local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieRss = .fmp_mockFitRss(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - res <- suppressMessages( - fineMappingPipeline( - gss, - methods = "susieInf", - initializeWithSusieInf = FALSE, - verbose = 1 + for (input in list(.fmp_qss, .fmp_gss)) { + kind <- class(input)[[1L]] + res <- suppressMessages( + fineMappingPipeline( + input, + methods = "susieInf", + initializeWithSusieInf = FALSE, + verbose = 1 + ) ) - ) - expect_s4_class(res, "GwasFineMappingResult") - expect_setequal(methodNames(res), "susieInf") + expect_s4_class(res, .fmp_resultClass[[kind]]) + expect_equal(methodNames(res), "susieInf", info = kind) + } }) test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown token", { @@ -4532,7 +4042,7 @@ test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown fitMvsusie = function(X, Y, ...) { list(vn = colnames(X), R = ncol(as.matrix(Y))) }, - # weights WITHOUT rownames -> .fmFoldWeights sets them from Xtr (1231) + # weights WITHOUT rownames -> .fmFoldWeights sets them from Xtr mvsusieWeights = function(mvsusieFit = NULL, ...) { matrix(0.01, length(mvsusieFit$vn), mvsusieFit$R) }, @@ -4545,7 +4055,7 @@ test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) ) Y <- matrix(rnorm(40), 20, 2) - # mvPrior carrying a residualVariance exercises line 1227 + # an mvPrior carrying a residualVariance hands it to the fit W <- pecotmr:::.fmFoldWeights( "mvsusie", X, @@ -4556,7 +4066,7 @@ test_that(".fmFoldWeights covers mvPrior residual var, missing rownames, unknown mvPrior = list(priorVariance = diag(2), residualVariance = diag(2)) ) expect_equal(rownames(W), colnames(X)) - # an unknown token falls through to NULL (1241) + # an unknown token falls through to NULL expect_null(pecotmr:::.fmFoldWeights("bogus", X, Y, 0.95, list(), NULL)) }) @@ -4587,7 +4097,7 @@ test_that(".fmWeightsCv fills Y rownames and reports per-fold fit failures", { 2, dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) ) - Y <- matrix(rnorm(20), 20, 1) # no rownames -> filled from X (1258) + Y <- matrix(rnorm(20), 20, 1) # no rownames -> filled from X expect_message( cv <- suppressWarnings(pecotmr:::.fmWeightsCv( X, @@ -4598,46 +4108,47 @@ test_that(".fmWeightsCv fills Y rownames and reports per-fold fit failures", { verbose = 1 )), "CV fold .* failed" - ) # 1291-1294 + ) }) -test_that(".fmWeightsCv skips a fold that holds out every sample", { - X <- matrix( - rbinom(40, 2, 0.4), - 20, - 2, - dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) - ) - Y <- matrix(rnorm(20), 20, 1, dimnames = list(rownames(X), NULL)) - sp <- data.frame(Sample = rownames(X), Fold = 1L) # single fold = all test -> 1273 - cv <- pecotmr:::.fmWeightsCv( - X, - Y, - tokens = "susie", - methodArgs = list(susie = list()), - fold = 1L, - samplePartition = sp, - verbose = 0 - ) - expect_true(all(is.na(cv$prediction[["susie_predicted"]]))) +test_that("fineMappingPipeline CV retains a lean per-fold fit", { + f <- .twcvFixture + expect_false(is.null(f$cv$foldFits)) + expect_equal(names(f$cv$foldFits), c("fold_1", "fold_2", "fold_3")) + # lean: only the fields the weight extractors read + fit1 <- f$cv$foldFits[["fold_1"]][["susie"]] + expect_true(all(c("pip", "alpha", "mu") %in% names(fit1))) + expect_false("lbf_variable" %in% names(fit1)) + # and it slices per method onto the row payload + expect_equal(names(f$slice$foldFits), c("fold_1", "fold_2", "fold_3")) }) # --- method-level branches (drive the pipeline methods with mocked fitters) --- test_that(".fmAfForX returns NULL when af yields nothing", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - local_mocked_bindings(af = function(...) NULL, .package = "pecotmr") + qd <- .fmp_qdA + local_mocked_bindings( + .qtlExtractBlock = function(...) { + list(af = numeric(0), variantIds = character(0)) + }, + .package = "pecotmr" + ) X <- matrix( 0, 3, 2, dimnames = list(paste0("s", 1:3), c("chr1:100:A:G", "chr1:200:A:G")) ) - expect_null(pecotmr:::.fmAfForX(qd, X, traitId = "ENSG_A")) + expect_null(pecotmr:::.fmAfForX( + qd, + X, + genotypeFilter = pecotmr:::.qtlResolveFilter(), + traitId = "ENSG_A" + )) }) -test_that("fineMappingPipeline(QtlDataset): explicit valid contexts arg is honored", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") +test_that("fineMappingPipeline(QtlDataset): a valid context is honored", { + qd <- .fmp_qdTwoCtxA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -4654,33 +4165,33 @@ test_that("fineMappingPipeline(QtlDataset): explicit valid contexts arg is honor ) ) expect_s4_class(res, "QtlFineMappingResult") + # The context left out is not fit. + expect_setequal(contexts(res), "brain") }) test_that("fineMappingPipeline(QtlDataset): region selects traits by rowRanges overlap", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), .package = "pecotmr" ) - region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 3000L)) + # ENSG_A spans 1000-1499 and ENSG_B 2000-2499: the region reaches only A. + region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 1600L)) res <- suppressMessages( fineMappingPipeline( - qd, + .fmp_qdAB, methods = "susie", region = region, initializeWithSusieInf = FALSE ) ) expect_s4_class(res, "QtlFineMappingResult") + expect_setequal(traitNames(res), "ENSG_A") }) test_that("fineMappingPipeline(QtlDataset): too few shared samples errors", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), # residualized X carries a sample absent from Y -> < 2 shared samples @@ -4709,7 +4220,7 @@ test_that("fineMappingPipeline(QtlDataset): too few shared samples errors", { }) test_that("fineMappingPipeline(QtlDataset): errors when no tuple produces a result", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmSerScreen = function(...) FALSE, # screen out every block @@ -4726,34 +4237,8 @@ test_that("fineMappingPipeline(QtlDataset): errors when no tuple produces a resu ) }) -test_that("fineMappingPipeline(QtlDataset): usePCA fine-maps top PCs of a multi-trait context", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - local_mocked_bindings( - extractBlockGenotypes = .fmp_mockExtractor(), - .fmFitSusieIndiv = .fmp_mockFitIndiv(), - .fmPostprocessOne = .fmp_mockPostprocess(), - .fmSerScreen = function(...) TRUE, - .package = "pecotmr" - ) - res <- suppressMessages( - fineMappingPipeline( - qd, - methods = "susie", - usePCA = TRUE, - nPCs = 1L, - cisWindow = 1000L, - initializeWithSusieInf = FALSE - ) - ) - expect_s4_class(res, "QtlFineMappingResult") - expect_true(any(grepl("PC", as.character(res$trait)))) -}) - test_that("fineMappingPipeline(QtlDataset): usePCA skips single-trait contexts", { - qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + qd <- .fmp_qdA local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -4777,7 +4262,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips single-trait contexts", }) test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersecting scope errors", { - mt <- .fmp_makeMultiStudy() + mt <- .fmp_msqd # The joint engine yields nothing for this scope -> the no-joint-fits stop. local_mocked_bindings( .fmDispatchJointSpecsMultiStudy = function(...) NULL, @@ -4793,16 +4278,16 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersec ) }) -# --- usePCA sub-branches. Use methods="mvsusie" so the univariate dispatch is -# skipped (no 1531 stop / SER entanglement); the PCA path still runs susie, and -# the mvsusie joint dispatch is mocked to keep a non-empty result (no 1647). +# --- usePCA sub-branches. The tests using methods = "mvsusie" skip the +# univariate dispatch (and its SER screen); the PCA path still runs susie, and +# the mocked mvsusie joint dispatch keeps the result non-empty. .fmp_jr <- function() { QtlFineMappingResult( studyName = "study1", context = "brain", trait = "ENSG_A", method = "mvsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4811,15 +4296,12 @@ test_that("fineMappingPipeline(MultiStudyQtlDataset): jointSpec with no intersec } test_that("fineMappingPipeline(QtlDataset): usePCA skips a context whose PCA yields no scores", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), .fmPostprocessOne = .fmp_mockPostprocess(), - .fmTopPcScores = function(...) NULL, # 1577 next + .fmTopPcScores = function(...) NULL, # PCA yields no scores .package = "pecotmr" ) res <- suppressMessages(fineMappingPipeline( @@ -4834,16 +4316,13 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a context whose PCA yie }) test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB cachedFMR <- QtlFineMappingResult( studyName = "study1", context = "brain", trait = "topPC1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -4872,14 +4351,11 @@ test_that("fineMappingPipeline(QtlDataset): usePCA reuses a cached PC entry", { initializeWithSusieInf = FALSE, fineMappingResult = cachedFMR )) - expect_true(any(as.character(res$trait) == "topPC1")) # 1584 cache hit + expect_true(any(as.character(res$trait) == "topPC1")) # from the cache }) test_that("fineMappingPipeline(QtlDataset): usePCA + region uses the region genotype block", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmFitSusieIndiv = .fmp_mockFitIndiv(), @@ -4896,14 +4372,11 @@ test_that("fineMappingPipeline(QtlDataset): usePCA + region uses the region geno nPCs = 1L, region = region )) - expect_true(any(grepl("PC", as.character(res$trait)))) # 1591-1592 region block + expect_true(any(grepl("PC", as.character(res$trait)))) }) test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block with too few shared samples", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), .fmResidGeno = function(x, ...) { @@ -4916,7 +4389,7 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block with too few c("chr1:100:A:G", "chr1:200:A:G") ) ) - }, # PC common < 2 -> 1595 + }, # < 2 samples shared with the PCs .fmDispatchJointSpecsQtlDataset = function(...) .fmp_jr(), .package = "pecotmr" ) @@ -4927,17 +4400,14 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block with too few nPCs = 1L, cisWindow = 1000L )) - expect_false(any(grepl("PC", as.character(res$trait)))) # 1595 + 1607 + expect_false(any(grepl("PC", as.character(res$trait)))) }) test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out by SER", { - qd <- .fmp_makeQtlDataset( - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) + qd <- .fmp_qdAB local_mocked_bindings( extractBlockGenotypes = .fmp_mockExtractor(), - .fmSerScreen = function(...) FALSE, # PC screened -> 1597 + .fmSerScreen = function(...) FALSE, # the PC block is screened out .fmDispatchJointSpecsQtlDataset = function(...) .fmp_jr(), .package = "pecotmr" ) @@ -4948,10 +4418,9 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out nPCs = 1L, cisWindow = 1000L )) - expect_false(any(grepl("PC", as.character(res$trait)))) # 1597 + 1607 + expect_false(any(grepl("PC", as.character(res$trait)))) }) - # --------------------------------------------------------------------------- # RSS panel filters: mafCutoff / macCutoff / imissCutoff on QtlSumStats and # GwasSumStats input. @@ -4961,11 +4430,12 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out # and the LD matrix are built, so the two cannot fall out of alignment. # --------------------------------------------------------------------------- -# @noRd -.rssf_qcd <- function() { +# The bundled QTL summary statistics, QC'd once: summaryStatsQc() is the slow +# step, and every test below only reads the result. +.rssf_ss <- local({ data(qtlSumStatsExample, envir = environment()) suppressMessages(summaryStatsQc(qtlSumStatsExample)) -} +}) # @noRd .rssf_n <- function(ss, ...) { @@ -4980,42 +4450,34 @@ test_that("fineMappingPipeline(QtlDataset): usePCA skips a PC block screened out } test_that("fineMappingPipeline(QtlSumStats) filters nothing by default", { - ss <- .rssf_qcd() + ss <- .rssf_ss expect_equal(.rssf_n(ss), sum(lengths(ss))) }) -test_that("fineMappingPipeline(QtlSumStats) drops panel-rare variants", { - ss <- .rssf_qcd() - full <- .rssf_n(ss) - loose <- .rssf_n(ss, mafCutoff = 0.05) - tight <- .rssf_n(ss, mafCutoff = 0.2) - expect_lt(loose, full) - expect_lt(tight, loose) -}) - -test_that("fineMappingPipeline RSS cutoffs agree with .panelVariantFilter", { +test_that("fineMappingPipeline RSS MAF cutoffs match .panelVariantFilter", { # The pipeline must drop exactly the variants the shared filter names -- # no more (which would mean something else is filtering) and no fewer - # (which would mean the cutoff silently did nothing). - ss <- .rssf_qcd() + # (which would mean the cutoff silently did nothing) -- so panel-rare + # variants go, and a tighter cutoff drops more. + ss <- .rssf_ss ids <- variantIds(ss) + kept <- sum(lengths(ss)) for (cut in c(0.05, 0.2)) { expected <- length(.panelVariantFilter( - ldReference(ss), + ldReference(ss)[[1L]], ids, PanelFilterParam(mafCutoff = cut) )) - expect_equal( - .rssf_n(ss, mafCutoff = cut), - expected, - label = str_c("mafCutoff ", cut) - ) + n <- .rssf_n(ss, mafCutoff = cut) + expect_equal(n, expected, label = str_c("mafCutoff ", cut)) + expect_lt(n, kept, label = str_c("mafCutoff ", cut)) + kept <- n } }) test_that("fineMappingPipeline RSS treats MAC as a MAF equivalent", { - ss <- .rssf_qcd() - nSamp <- ncol(ldReference(ss)) + ss <- .rssf_ss + nSamp <- ncol(ldReference(ss)[[1L]]) expect_equal( .rssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .rssf_n(ss, mafCutoff = 0.1) @@ -5023,16 +4485,15 @@ test_that("fineMappingPipeline RSS treats MAC as a MAF equivalent", { }) test_that("fineMappingPipeline RSS honours a missingness cutoff", { - ss <- .rssf_qcd() + ss <- .rssf_ss expect_lt(.rssf_n(ss, imissCutoff = 0), sum(lengths(ss))) expect_equal(.rssf_n(ss, imissCutoff = 1), sum(lengths(ss))) }) - test_that(".fmExtractZn keeps z, ids and n aligned after filtering", { - ss <- .rssf_qcd() + ss <- .rssf_ss entry <- pecotmr:::.collectionEntry(ss, 1L) - sketch <- ldReference(ss) + sketch <- ldReference(ss)[[1L]] unfiltered <- pecotmr:::.fmExtractZn(entry, "t") filtered <- suppressMessages(pecotmr:::.fmExtractZn( entry, @@ -5125,21 +4586,6 @@ test_that("FineMappingMethodsParam takes lists or constructors per entry", { ) }) -test_that("fineMappingPipeline accepts the record and the character form", { - skip_if_not_installed("susieR") - byName <- pecotmr:::.fmNormalizeMethods( - c("susie", "susieInf"), - inputKind = "QtlDataset" - ) - expect_equal(byName$tokens, c("susie", "susieInf")) - byRecord <- pecotmr:::.fmNormalizeMethods( - FineMappingMethodsParam(qtlDatasetMethods = list(susie = list(L = 3))), - inputKind = "QtlDataset" - ) - expect_equal(byRecord$tokens, "susie") - expect_equal(byRecord$methodArgs$susie$L, 3) -}) - test_that("argument checking narrows to the engine the input class reaches", { skip_if_not_installed("susieR") skip_if_not_installed("mvsusieR") @@ -5296,9 +4742,11 @@ test_that("CredibleSetParam owns the single-effect bounds", { )$maxNumSingleEffectsGreedy, 3L ) - # addSusieInf stands alone: it selects a chained initialisation between - # methods rather than describing credible sets. - expect_false("addSusieInf" %in% names(formals(CredibleSetParam))) + # initializeWithSusieInf stands alone: it selects a chained + # initialisation between methods rather than describing credible sets. + expect_false( + "initializeWithSusieInf" %in% names(formals(CredibleSetParam)) + ) expect_false("fitStructureArgs" %in% getNamespaceExports("pecotmr")) }) @@ -5319,6 +4767,11 @@ test_that("SignalScreenParam resolves each metric to a pipeline spec", { # list(metric, cutoff). .asScreen() canonicalizes either. expect_null(pecotmr:::.screenResolve(SignalScreenParam())) expect_equal(pecotmr:::.screenResolve(SignalScreenParam(pip = 0.5)), 0.5) + # A per-context pip vector passes through with its names. + expect_equal( + pecotmr:::.screenResolve(SignalScreenParam(pip = c(brain = 0.3))), + c(brain = 0.3) + ) expect_equal( pecotmr:::.screenResolve(SignalScreenParam(absZ = 5)), list(metric = "absZ", cutoff = 5) @@ -5353,6 +4806,31 @@ test_that("SignalScreenParam rejects two metrics and negative absZ / bf", { ) }) +test_that(".fmSerScreen / .fmScreenActive / .fmSerScreenColumns", { + set.seed(2) + X <- matrix( + rnorm(40), + 20, + 2, + dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) + ) + y <- rnorm(20) + expect_true(pecotmr:::.fmSerScreen(X, y, 0)) # disabled + expect_true(pecotmr:::.fmSerScreen(X, c(1, rep(NA, 19)), 0.5)) # < 2 obs + expect_type(pecotmr:::.fmSerScreen(X, y, 0.5), "logical") # real susie fit + local_mocked_bindings( + susie = function(...) stop("boom"), + .package = "susieR" + ) + expect_true(pecotmr:::.fmSerScreen(X, y, 0.5)) # fit fails -> keep + expect_false(pecotmr:::.fmScreenActive(0)) + expect_true(pecotmr:::.fmScreenActive(0.5)) + expect_length( + pecotmr:::.fmSerScreenColumns(X, matrix(rnorm(40), 20, 2), 0), + 2L + ) +}) + test_that("every recursion forwards each cfg field its callee accepts", { ns <- asNamespace("pecotmr") cases <- list( @@ -5379,10 +4857,7 @@ test_that("every recursion forwards each cfg field its callee accepts", { ) for (cs in cases) { fields <- .cfgFieldNames(cs$builder) - accepted <- setdiff( - names(formals(get(cs$callee, envir = ns))), - "..." - ) + accepted <- setdiff(names(formals(get(cs$callee, envir = ns))), "...") passed <- .argNamesPassed(cs$site) # A field the record carries AND the callee accepts must be passed. dropped <- setdiff(intersect(fields, accepted), passed) @@ -5424,7 +4899,7 @@ test_that("MultiStudyQtlDataset takes every component argument", { 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") + qd <- .fmp_qdA # 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( @@ -5444,7 +4919,7 @@ test_that("QtlDataset: a CV-only run keeps the CV and skips the full fit", { verbose = 0 )) expect_equal(nrow(res), 1L) - expect_equal(lengths(res), 0L) + expect_equal(unname(lengths(res)), 0L) expect_null(susieFit( res, studyName = "study1", @@ -5461,7 +4936,7 @@ test_that("QtlDataset: a CV-only run keeps the CV and skips the full fit", { ) 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") + expect_error(writeBed(res, tempfile(fileext = ".bed")), "fitFullData") }) test_that(".fmMergeEntries keeps a merged cross-validation-only row fit-free", { @@ -5487,8 +4962,8 @@ test_that(".fmCacheForRun reuses only rows that carry what the run asks for", { 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), + FineMappingRow(vid, list(a = 1), tl, cvResult = cv), + FineMappingRow(vid, list(a = 1), tl), pecotmr:::.fmCvOnlyRow(cv) ) ) @@ -5504,7 +4979,7 @@ test_that(".fmCacheForRun reuses only rows that carry what the run asks for", { ) }) -test_that("CredibleSetParam accessors read and replace, L is get-only", { +test_that("CredibleSetParam fields read and replace, L is fixed", { cs <- CredibleSetParam(coverage = 0.95) expect_equal(csCoverage(cs), 0.95) expect_equal(maxNumSingleEffects(cs), 10L) @@ -5513,34 +4988,26 @@ test_that("CredibleSetParam accessors read and replace, L is get-only", { # Copy semantics: replacement rebinds a modified copy, so another name # holding the original still sees the old value. cs2 <- cs - csCoverage(cs2) <- 0.9 + cs2$coverage <- 0.9 expect_equal(csCoverage(cs2), 0.9) expect_equal(csCoverage(cs), 0.95) expect_s4_class(cs2, "CredibleSetParam") # The slot's declared type still holds through a replacement. - expect_error(csCoverage(cs) <- "wide", "not valid for @.+coverage") + expect_error(cs$coverage <- "wide", "coverage") - # L / Lgreedy are deliberately get-only: they are seeded onto each + # L / Lgreedy are deliberately fixed: they are seeded onto each # SuSiE-family token's own arguments, so changing one needs a refit, not - # a re-summary. A setter would hand back a record that looks applied. - ns <- asNamespace("pecotmr") - expect_false(exists("setL", envir = ns, inherits = FALSE)) - expect_false(exists("setLgreedy", envir = ns, inherits = FALSE)) + # a re-summary. A replacement would hand back a record that looks + # applied, so `$<-` refuses them. + expect_error(cs$maxNumSingleEffects <- 5L, "needs a refit") + expect_error(cs$maxNumSingleEffectsGreedy <- 2L, "needs a refit") expect_true(is.function(maxNumSingleEffectsGreedy)) }) -test_that("every settable CredibleSetParam field has both accessors", { - # The pairing is the contract: a field you can read and not write is a - # deliberate exception, so it must be one of exactly these two. - # - # The accessor is now the field name itself -- the get* prefix is gone -- - # except where the bare field name would have been unusable or taken, so - # those three are named here rather than derived. Writers are the - # matching `<-` replacement generics. - getOnly <- c("maxNumSingleEffects", "maxNumSingleEffectsGreedy") - # The slots now carry their accessors' names, so `coverage` is the only - # field whose accessor is not derivable from it. +test_that("every CredibleSetParam field has a getter", { + # The getter is the field name itself, except `coverage`, whose bare name + # is an IRanges generic -- so that one is named here, not derived. renamed <- c(coverage = "csCoverage") ns <- asNamespace("pecotmr") for (f in names(formals(CredibleSetParam))) { @@ -5549,21 +5016,12 @@ test_that("every settable CredibleSetParam field has both accessors", { exists(accessor, envir = ns, inherits = FALSE), info = paste("no accessor for", f) ) - # The writer is the replacement form of the accessor name, not a - # set* function: `csCoverage(p) <- v`, never `setCoverage(p, v)`. - expect_equal( - exists(str_c(accessor, "<-"), envir = ns, inherits = FALSE), - !is_in(f, getOnly), - info = paste("replacement presence wrong for", f) - ) } }) -test_that("CredibleSetParam accessors read and replace every field", { - # The pairing test above asserts the accessors EXIST; this one dispatches - # them. Existence is checked with exists(), which never reaches the - # generic, so without this the setGeneric bodies in AllGenerics.R and the - # copy semantics of each setter go unexercised. +test_that("CredibleSetParam getters read and $<- replaces every field", { + # Dispatching each getter is what exercises the setGeneric bodies in + # AllGenerics.R; existence alone never reaches them. cs <- CredibleSetParam() expect_equal(secondaryCoverage(cs), c(0.7, 0.5)) expect_equal(signalCutoff(cs), 0.025) @@ -5574,12 +5032,12 @@ test_that("CredibleSetParam accessors read and replace every field", { # Replacement on a copy; `cs` itself keeps its original values. edited <- cs - secondaryCoverage(edited) <- 0.6 - signalCutoff(edited) <- 0.1 - minAbsCorr(edited) <- 0.5 - medianAbsCorr(edited) <- 0.4 - includeAllCs(edited) <- TRUE - perCsColumns(edited) <- "alpha" + edited$secondaryCoverage <- 0.6 + edited$signalCutoff <- 0.1 + edited$minAbsCorr <- 0.5 + edited$medianAbsCorr <- 0.4 + edited$includeAllCs <- TRUE + edited$perCsColumns <- "alpha" expect_equal(secondaryCoverage(edited), 0.6) expect_equal(signalCutoff(edited), 0.1) expect_equal(minAbsCorr(edited), 0.5) @@ -5589,8 +5047,9 @@ test_that("CredibleSetParam accessors read and replace every field", { expect_equal(secondaryCoverage(cs), c(0.7, 0.5)) expect_false(includeAllCs(cs)) - # Replacement revalidates, so a wrong-typed value is refused. - expect_error(includeAllCs(cs) <- "yes", "includeAllCs") + # Replacement goes through the constructor, so a wrong-typed value is + # refused exactly as CredibleSetParam() refuses it. + expect_error(cs$includeAllCs <- "yes", "includeAllCs") }) # --------------------------------------------------------------------------- @@ -5649,24 +5108,23 @@ test_that("CredibleSetParam validity catches range and length errors", { ) }) -test_that("CredibleSetParam setters are held to the same checks", { +test_that("CredibleSetParam replacements are held to the same checks", { cs <- CredibleSetParam() - # The setter path used to bypass every one of these: its body is - # `x@slot <- value; validObject(x)`, and before setValidity() existed - # validObject() only checked the slot's type. - expect_error(csCoverage(cs) <- 1.5, "coverage") - expect_error(csCoverage(cs) <- c(0.9, 0.95), "coverage") - expect_error(minAbsCorr(cs) <- -1, "minAbsCorr") - expect_error(signalCutoff(cs) <- 2, "signalCutoff") - expect_error(secondaryCoverage(cs) <- c(0.7, 3), "secondaryCoverage") - # perCsColumns was the sharpest asymmetry: the constructor refused a - # bad level via arg_match() while the setter accepted it. - expect_error(perCsColumns(cs) <- "bogus", "perCsColumns") + # A replacement is a rebuild through CredibleSetParam(), so it is refused + # exactly where the constructor would refuse the value. + expect_error(cs$coverage <- 1.5, "coverage") + expect_error(cs$coverage <- c(0.9, 0.95), "coverage") + expect_error(cs$minAbsCorr <- -1, "minAbsCorr") + expect_error(cs$signalCutoff <- 2, "signalCutoff") + expect_error(cs$secondaryCoverage <- c(0.7, 3), "secondaryCoverage") + # perCsColumns was the sharpest asymmetry of the old setters: the + # constructor refused a bad level via arg_match() while they accepted it. + expect_error(cs$perCsColumns <- "bogus", "perCsColumns") # Valid replacements still go through. ok <- cs - csCoverage(ok) <- 0.9 - minAbsCorr(ok) <- 0.5 - medianAbsCorr(ok) <- 0.4 + ok$coverage <- 0.9 + ok$minAbsCorr <- 0.5 + ok$medianAbsCorr <- 0.4 expect_equal(csCoverage(ok), 0.9) expect_equal(minAbsCorr(ok), 0.5) expect_equal(medianAbsCorr(ok), 0.4) @@ -5725,36 +5183,6 @@ test_that(".fmOwnedEngineArgs owns nothing for an unknown engine", { ) }) -test_that(".fmBlockIdRange recovers a block boundary the variants cannot give", { - # Adjacent LD blocks leave gaps, so the realized variant span is narrower - # than the block; only blockId carries the boundary. - gr <- .fmBlockIdRange("chr22_49355984_50799822") - expect_s4_class(gr, "GRanges") - expect_identical(as.character(GenomicRanges::seqnames(gr)), "chr22") - expect_identical(GenomicRanges::start(gr), 49355984L) - expect_identical(GenomicRanges::end(gr), 50799822L) - # the chr:start-end spelling works too - expect_identical( - as.character(.fmBlockIdRange("chr1:100-200")), - as.character(GenomicRanges::GRanges("chr1:100-200")) - ) - # anything that is not coordinates is not guessed at - expect_null(.fmBlockIdRange("ENSG00000283047")) - expect_null(.fmBlockIdRange(NA_character_)) - expect_null(.fmBlockIdRange(NULL)) - expect_null(.fmBlockIdRange(c("chr1_1_2", "chr1_3_4"))) -}) - -test_that(".fmRssFitWindow prefers the block boundary over the variant span", { - ids <- c("chr22:49363017:A:T", "chr22:50598205:C:G") - withBlock <- .fmRssFitWindow(NULL, ids, "chr22_49355984_50799822") - expect_identical(GenomicRanges::start(withBlock), 49355984L) - # No parseable blockId -> the fit's own variants define the window. - noBlock <- .fmRssFitWindow(NULL, ids, NULL) - expect_identical(GenomicRanges::start(noBlock), 49363017L) - expect_identical(GenomicRanges::end(noBlock), 50598205L) -}) - test_that(".fmBlockWindow falls back to the trait's own cis window", { data(qtlDatasetExample) explicit <- GenomicRanges::GRanges("chr1:1-999") @@ -5769,7 +5197,9 @@ test_that(".fmBlockWindow falls back to the trait's own cis window", { cfgNarrow <- list(data = qtlDatasetExample, cisWindow = 1000) cfgWide <- list(data = qtlDatasetExample, cisWindow = 500000) ctx <- contexts(qtlDatasetExample)[[1L]] - tid <- rownames(molecularTraits(qtlDatasetExample, contexts = ctx))[[1L]] + tid <- rownames(molecularTraits(qtlDatasetExample, context = ctx)[[ctx]])[[ + 1L + ]] narrow <- .fmBlockWindow(NULL, ctx, tid, cfgNarrow) wide <- .fmBlockWindow(NULL, ctx, tid, cfgWide) expect_lt(GenomicRanges::start(wide), GenomicRanges::start(narrow)) @@ -5780,29 +5210,46 @@ test_that(".fmBlockWindow falls back to the trait's own cis window", { ) }) -test_that("a supplied block key survives into the result; a seqname fallback does not", { +test_that("a GWAS row carries its block name and window into its fit", { data(gwasSumStatsS4Example) - gss <- gwasSumStatsS4Example - gr <- .collectionEntry(gss, 1L) + gr <- .collectionEntry(gwasSumStatsS4Example, 1L) derived <- .fmGwasRangeKey(gr) - # (a) No manifest and no explicit blockId: GwasSumStats() falls back to the - # bare seqname, which carries no coordinates and must NOT override the - # entry's own range key. - bare <- gss - S4Vectors::mcols(bare)$blockId <- rep("chr22", nrow(bare)) - expect_identical(.fmGwasBlockId(bare, 1L, gr), derived) + # (a) No windows: GwasSumStats() names the row by its seqname, which the + # fit keeps, and its window is the span it was built with. + bare <- GwasSumStats(studyName = "s", entry = list(gr), genome = "hg19") + block <- .fmGwasBlock(bare, 1L, gr, .rowRegions(bare)) + expect_identical(block$id, "chr22") + expect_false(block$given) + expect_identical(as.character(block$region), as.character(range(gr))) - # (b) A coordinate-bearing key -- from an ldBlocks manifest or an explicit - # vector -- IS the block boundary and wins. Adjacent blocks leave gaps, so + # (b) A range the caller gave -- here a `region` window keyed by name -- + # IS the block boundary and keeps its key. Adjacent blocks leave gaps, so # it is wider than the variants that survived QC. - supplied <- gss - key <- "chr22_1_50000000" - S4Vectors::mcols(supplied)$blockId <- rep(key, nrow(supplied)) - expect_identical(.fmGwasBlockId(supplied, 1L, gr), key) - expect_false(identical(.fmGwasBlockId(supplied, 1L, gr), derived)) + named <- GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg19", + region = GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(1L, 50000000L), + blockId = "b7" + ) + ) + block <- .fmGwasBlock(named, 1L, gr, .rowRegions(named)) + expect_identical(block$id, "b7") + expect_true(block$given) + expect_identical(as.character(block$region), "chr22:1-50000000") + + # (c) A name is kept as it is; only a row with none, from a collection + # saved before the column existed, is named by its span. + expect_identical( + .fmGwasBlockName("chr22_1_50000000", gr), + "chr22_1_50000000" + ) + expect_identical(.fmGwasBlockName(NA_character_, gr), derived) - # (c) The resume cache keys on the DERIVED range either way, so supplying a + # (d) The resume cache keys on the DERIVED range either way, so supplying a # wider boundary cannot make the cache miss. expect_identical(.fmGwasRangeKey(gr), derived) }) @@ -5810,7 +5257,7 @@ test_that("a supplied block key survives into the result; a seqname fallback doe # --------------------------------------------------------------------------- # Provenance columns (dataType / dataSource / standardized) # -# These three are what exportToBed() / exportToVcf() publish as data_type, +# These three are what writeBed() / writeGwasVcf() publish as data_type, # data_source and weight_standardized. Only the first is an outside fact; the # other two follow from the branch the pipeline took, so they are derived and # the summary-statistics methods refuse to be told. @@ -5862,7 +5309,7 @@ test_that("fineMappingPipeline(QtlDataset) omits dataType when not supplied", { test_that("fineMappingPipeline(QtlSumStats) records sumstat / standardized", { res <- suppressWarnings(suppressMessages(fineMappingPipeline( - .rssf_qcd(), + .rssf_ss, methods = "susie", dataType = "bulk_rnaseq" ))) @@ -5880,7 +5327,7 @@ test_that("no pipeline takes a weight-scale declaration any more", { # derived and a declaration could only contradict it. expect_error( fineMappingPipeline( - .rssf_qcd(), + .rssf_ss, methods = "susie", weightStandardized = FALSE ), @@ -5899,7 +5346,7 @@ test_that("no pipeline takes a weight-scale declaration any more", { }) test_that(".fmMsDataSource leaves a mixed collection's joint rows NA", { - expect_true(is.na(pecotmr:::.fmMsDataSource(.fmp_makeMultiStudy()))) + expect_true(is.na(pecotmr:::.fmMsDataSource(.fmp_msqd))) }) test_that(".fmMsDataSource gives an individual-level collection's joint rows", { @@ -5923,6 +5370,7 @@ test_that("individual-level genotypes reach the fitter standardized", { X <- pecotmr:::.fmResidGeno( qtlDatasetExample, ResidualizationParam(), + genotypeFilter = pecotmr:::.qtlResolveFilter(), contexts = "brain", traitId = "ENSG_example", cisWindow = 1e6 @@ -5932,24 +5380,11 @@ test_that("individual-level genotypes reach the fitter standardized", { expect_true(all(abs(sds[sds > 0] - 1) < 1e-10)) }) -test_that("a constant genotype column comes back as zeros, not NaN", { - # `.qtlResidualizeQr()` treats anything below sqrt(.Machine$double.eps) as - # constant: lm.fit residuals of a constant column are ~1e-16 rather than - # 0, and dividing the (also tiny) residuals by that amplifies roundoff to - # unit scale. The column is zeroed instead, and .dropZeroVariance() - # removes it downstream. - Y <- cbind(a = c(1, 2, 3, 4), b = c(2, 2, 2, 2)) - out <- pecotmr:::.qtlResidualizeQr(Y, NULL, scaleResiduals = TRUE) - expect_equal(unname(out[, "b"]), rep(0, 4)) - expect_equal(sd(out[, "a"]), 1) - expect_false(anyNA(out)) -}) - test_that("the genotype scale comes from the accessor, not the pipeline", { - # ONE knob: ResidualizationParam(scaleResiduals=) per call, with the - # QtlDataset's own slot as the default. The pipelines add no mechanism of - # their own -- they only RECORD what the accessor resolved, so a wrong - # record and a wrong scale cannot come apart. + # ONE knob: ResidualizationParam(scaleResiduals=), TRUE when unset. The + # pipelines add no mechanism of their own -- they only RECORD what the + # residualizer resolved, so a wrong record and a wrong scale cannot come + # apart. data(qtlDatasetExample, envir = environment()) recorded <- function(..., dataset = qtlDatasetExample) { res <- suppressMessages(fineMappingPipeline( @@ -5963,11 +5398,6 @@ test_that("the genotype scale comes from the accessor, not the pipeline", { expect_true(recorded()) expect_true(recorded(scaleResiduals = TRUE)) expect_false(recorded(scaleResiduals = FALSE)) - # Unset falls back to the object, which is where the default lives. - off <- methods::initialize(qtlDatasetExample, scaleResiduals = FALSE) - expect_false(recorded(dataset = off)) - # An explicit per-call value overrides the object either way. - expect_true(recorded(scaleResiduals = TRUE, dataset = off)) }) test_that("the pipelines add no second standardization mechanism", { @@ -5988,7 +5418,11 @@ test_that("the hatch does not reach a summary-statistics fit", { # There are no genotypes to scale, and the RSS likelihood is in # standardized units whatever anyone asks, so the flag stays TRUE. res <- suppressWarnings(suppressMessages( - fineMappingPipeline(.rssf_qcd(), methods = "susie") + fineMappingPipeline( + .rssf_ss, + methods = "susie", + residualizationParam = ResidualizationParam(scaleResiduals = FALSE) + ) )) expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) }) @@ -6005,7 +5439,7 @@ test_that("QtlDataset: joint fits get every caller setting", { rp <- ResidualizationParam(scaleResiduals = FALSE) expect_error( suppressMessages(fineMappingPipeline( - .fmp_makeQtlDataset(contexts = c("brain", "liver")), + .fmp_qdTwoCtxAB, methods = "mvsusie", traitId = "ENSG_A", cisWindow = 1000L, @@ -6038,7 +5472,7 @@ test_that("MultiStudyQtlDataset: per-study joint fits get every setting", { rp <- ResidualizationParam(scaleResiduals = FALSE) expect_error( suppressMessages(fineMappingPipeline( - .fmp_makeMultiStudy(), + .fmp_msqd, methods = "mvsusie", cisWindow = 1000L, jointSpecification = "context", @@ -6060,7 +5494,7 @@ test_that("MultiStudyQtlDataset: per-study joint fits get every setting", { ind$args$pipCutoffToSkip, pecotmr:::.screenResolve(SignalScreenParam(pip = 0.1)) ) - expect_equal(mafCutoff(ind$data), 0.05) + expect_equal(ind$args$genotypeFilter$mafCutoff, 0.05) }) test_that("MultiStudyQtlDataset: cross-study joint fits get their settings", { @@ -6071,7 +5505,7 @@ test_that("MultiStudyQtlDataset: cross-study joint fits get their settings", { panel <- PanelFilterParam(mafCutoff = 0.05) expect_error( suppressMessages(fineMappingPipeline( - .fmp_makeMultiStudy(), + .fmp_msqd, methods = "mvsusie", jointSpecification = "study", fitRetention = "full", @@ -6084,15 +5518,14 @@ test_that("MultiStudyQtlDataset: cross-study joint fits get their settings", { 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) +.fmp_withLdMatrix <- function(gss, nSamples = ncol(ldReference(gss)[[1L]])) { + panel <- ldReference(gss)[[1L]] ld <- LdMatrix( unname(computeLd(panel)), variants = SummarizedExperiment::rowRanges(panel), @@ -6103,16 +5536,19 @@ test_that("MultiStudyQtlDataset: cross-study joint fits get their settings", { entry = list(.collectionEntry(gss, 1L)), genome = "hg19", ldReference = ld, - qcInfo = qcInfo(gss) + qcOptions = qcOptions(gss) ) } +# A real susie fit. L = 4 still finds the example's three credible sets, and +# fits cheaper than the default L = 10; every route compared uses it. # @noRd .fmp_fitSusie <- function(x) { suppressWarnings(suppressMessages(fineMappingPipeline( x, methods = "susie", - initializeWithSusieInf = FALSE + initializeWithSusieInf = FALSE, + credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L) ))) } @@ -6127,13 +5563,13 @@ test_that("fine-mapping with an LdMatrix reference matches its panel", { viaPanel <- .fmp_fitSusie(gss) expect_equal(pip(viaMatrix), pip(viaPanel)) expect_equal(credibleSets(viaMatrix), credibleSets(viaPanel)) - expect_s4_class(ldReference(viaMatrix), "LdMatrix") + expect_s4_class(ldReference(viaMatrix)[[1L]], "LdMatrix") }) test_that("an RSS block reads a genotype reference's factor, not its LD", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example - panel <- ldReference(gss) + panel <- ldReference(gss)[[1L]] ids <- names(SummarizedExperiment::rowRanges(panel))[1:25] plain <- .fmRssLd(panel, ids, "susie", FALSE) expect_null(plain$R) @@ -6147,7 +5583,12 @@ test_that("an RSS block reads a genotype reference's factor, not its LD", { expect_equal(both$R, .ldFromRef(panel, ids, label = "t")) expect_identical(both$X, plain$X) } - ldOnly <- .fmRssLd(ldReference(.fmp_withLdMatrix(gss)), ids, "susie", FALSE) + ldOnly <- .fmRssLd( + ldReference(.fmp_withLdMatrix(gss))[[1L]], + ids, + "susie", + FALSE + ) expect_null(ldOnly$X) expect_equal(ldOnly$R, .ldFromRef(panel, ids, label = "t")) }) @@ -6155,7 +5596,7 @@ test_that("an RSS block reads a genotype reference's factor, not its LD", { test_that("fine-mapping runs on a GenotypeMixture reference", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example - panel <- ldReference(gss) + panel <- ldReference(gss)[[1L]] mix <- GenotypeMixture( list(a = panel[, 1:80], b = panel[, 81:165]), mixtureWeights = c(0.5, 0.5) @@ -6165,10 +5606,10 @@ test_that("fine-mapping runs on a GenotypeMixture reference", { entry = list(.collectionEntry(gss, 1L)), genome = "hg19", ldReference = mix, - qcInfo = qcInfo(gss) + qcOptions = qcOptions(gss) ) res <- .fmp_fitSusie(withMix) - expect_s4_class(ldReference(res), "GenotypeMixture") + expect_s4_class(ldReference(res)[[1L]], "GenotypeMixture") expect_true(all(is.finite(unlist(pip(res))))) }) @@ -6191,3 +5632,197 @@ test_that("the rFinite default needs the reference's size", { expect_identical(.fmResolveRFinite(50, TRUE, "none", unknown), 50) expect_null(.fmResolveRFinite(NULL, FALSE, "none", unknown)) }) + +# =========================================================================== +# Per-row LD references +# =========================================================================== + +# Two QtlSumStats rows (contexts c1, c2) carrying the same z over five +# variants, each on the LD reference given for it. +.fmp_twoRefSs <- function(refs) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:5), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = c(6, 5.5, 1, 0.5, 0.2), + N = 1000L + ) + QtlSumStats( + studyName = c("S", "S"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + entry = list(gr, gr), + genome = "hg19", + ldReference = refs, + qcOptions = list(step1 = "ok") + ) +} + +# An LdMatrix over those five variants, with nSamples recorded. +.fmp_ldm <- function(rho) { + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) + LdMatrix( + `dimnames<-`(rho^abs(outer(1:5, 1:5, "-")), list(ids, ids)), + nSamples = 1000L + ) +} + +test_that("each QtlSumStats row is fine-mapped against its own LD reference", { + weak <- .fmp_ldm(0.1) + strong <- .fmp_ldm(0.95) + res <- suppressMessages(suppressWarnings( + fineMappingPipeline( + .fmp_twoRefSs(list(weak, strong)), + methods = "susie" + ) + )) + c1 <- which(res$context == "c1") + c2 <- which(res$context == "c2") + # The result keeps each row on the reference its fit read. + expect_identical(pecotmr:::.rowLdRef(res, c1), weak) + expect_identical(pecotmr:::.rowLdRef(res, c2), strong) + # Identical z under different LD gives different fits: each row was fit + # against its own reference, not the first one's. + pip <- function(i) { + pecotmr:::.fmrPartsSusieFit(pecotmr:::.fmrRowParts(res, i))$pip + } + expect_false(isTRUE(all.equal(pip(c1), pip(c2)))) +}) + +test_that("mvsusie on QtlSumStats refuses contexts on two LD references", { + ss <- .fmp_twoRefSs(list(.fmp_ldm(0.1), .fmp_ldm(0.95))) + expect_error( + suppressMessages(fineMappingPipeline(ss, methods = "mvsusie")), + "a joint fit uses one LD matrix" + ) +}) + +# =========================================================================== +# A GWAS row spanning a whole chromosome is fine-mapped, but said +# =========================================================================== + +# A study's row over `starts` on chr1. +.fmp_spanningGwas <- function(starts, studies = "G1") { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(starts, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", starts), + A1 = "A", + A2 = "G", + Z = seq_along(starts) / 10, + N = 1000L + ) + GwasSumStats( + studyName = studies, + entry = rep(list(gr), length(studies)), + genome = "hg19", + qcOptions = list(step1 = "ok") + ) +} + +test_that(".fmWarnChromosomeRows flags rows spanning a chromosome's worth", { + # An LD block's worth of variants passes in silence. + expect_silent( + pecotmr:::.fmWarnChromosomeRows(.fmp_spanningGwas(c(100L, 5e6))) + ) + expect_warning( + pecotmr:::.fmWarnChromosomeRows(.fmp_spanningGwas(c(100L, 3e7))), + "20 Mb, as a whole chromosome does \\(G1 chr1_100_30000000\\)" + ) + # Past five rows the list is cut short. + six <- .fmp_spanningGwas(c(100L, 3e7), studies = str_c("G", 1:6)) + expect_warning( + pecotmr:::.fmWarnChromosomeRows(six), + "6 GWAS row\\(s\\).*G5 chr1_100_30000000, \\.\\.\\.\\)" + ) +}) + +test_that("fineMappingPipeline(QtlSumStats): cisWindow sets each window", { + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieRss = .fmp_mockFitRss(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr" + ) + ss <- .fmp_qss + ss$traitPos <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(300L, width = 1L) + ) + res <- suppressMessages(fineMappingPipeline( + ss, + methods = "susie", + cisWindow = 100, + initializeWithSusieInf = FALSE + )) + expect_identical(as.character(genomicRegion(res)), "chr1:200-400") + expect_equal(length(res[[1L]]), 3L) + # The selection is parsed before the window is laid, so naming a context + # works alongside it. + picked <- suppressMessages(fineMappingPipeline( + ss, + methods = "susie", + contexts = "c1", + cisWindow = 100, + initializeWithSusieInf = FALSE + )) + expect_identical(as.character(genomicRegion(picked)), "chr1:200-400") + # Without one, the result keeps the tuple's own window. + plain <- suppressMessages(fineMappingPipeline( + .fmp_qss, + methods = "susie", + initializeWithSusieInf = FALSE + )) + expect_identical(as.character(genomicRegion(plain)), "chr1:100-500") + expect_error( + fineMappingPipeline( + .fmp_qss, + methods = "susie", + cisWindow = 100 + ), + "laid around each tuple's trait position" + ) +}) + +test_that("fineMappingPipeline refuses a phenotype QC its fits cannot take", { + # Resolved before any study runs: a fit cannot take a missing phenotype, + # so naAction = "keep" is refused up front, on either input form. + keep <- PhenotypeFilterParam(naAction = "keep") + expect_error( + fineMappingPipeline( + .fmp_qdA, + methods = "susie", + phenotypeFilterParam = keep + ), + "naAction = \"keep\" is not available" + ) + expect_error( + fineMappingPipeline( + .fmp_msqd, + methods = "susie", + phenotypeFilterParam = keep + ), + "naAction = \"keep\" is not available" + ) +}) + +# =========================================================================== +# .fmAfByVar +# =========================================================================== + +test_that(".fmAfByVar reads AF, and is NULL when af was never declared", { + mk <- function(cm) { + .dfToEntryGranges(suppressWarnings(.resolveSumstatCols( + .afm_df("effect_allele_frequency", 0.8), + cm, + "lbl" + ))) + } + gA <- mk(.afm_cm(af = "effect_allele_frequency")) + expect_equal(unname(.fmAfByVar(gA, "chr1:100:A:G")), 0.8) + gM <- mk(.afm_cm(maf = "effect_allele_frequency")) + expect_null(.fmAfByVar(gM, "chr1:100:A:G")) +}) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 568d81d0..0afcabd8 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -1,100 +1,31 @@ # Tests for FineMappingRow (S4 class) -# Helper for adjustPips tests, migrated from test_dataStructures.R - -.makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { - p <- length(vids) - set.seed(11L) - lbf <- matrix( - rnorm(maxNumSingleEffects * p), - nrow = maxNumSingleEffects, - ncol = p - ) - colnames(lbf) <- vids - alpha <- lbfToAlpha(lbf) - pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) - fineMappingRow( - variantIds = vids, - susieFit = list( - pip = pip, - alpha = alpha, - lbf_variable = lbf, - mu = matrix(0, maxNumSingleEffects, p), - X_column_scale_factors = rep(1, p) - ), - topLoci = data.frame( - variant_id = vids, - pip = pip, - betahat = rep(0, p), - sebetahat = rep(1, p), - stringsAsFactors = FALSE - ) - ) -} - - # =========================================================================== -# Tests migrated from test_dataStructures.R (topLoci, adjustPips) +# A row as GRanges, and adjustPips on a kept subset # =========================================================================== -test_that(".fmrRowTopLoci() tables convert to ranges", { - tl <- data.frame( - variant_id = c("1:100:A:G", "1:200:C:T"), - pip = c(0.9, 0.1), - betahat = c(0.5, -0.2), - sebetahat = c(0.1, 0.2), - cs = c(1L, 0L), - method = "susie", - stringsAsFactors = FALSE - ) - ent <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl - ) - # .fmrRowTopLoci() is the per-row table; topLoci() converts once, after - # the aggregate view has stacked the rows, so the conversion is tested - # through the converter it now lives in. - out <- .fmrRowTopLoci(ent) - expect_s3_class(out, "data.frame") - gr <- pecotmr:::.fmeTopLociGRanges(out) - expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 2) - expect_equal(S4Vectors::mcols(gr)$pip, c(0.9, 0.1)) -}) - - -test_that(".fmrRowTopLoci() empty input converts to empty ranges", { - ent <- fineMappingRow( - variantIds = character(0), +test_that("as(row, 'GRanges') is the element a collection stores", { + ids <- c("chr1:100:A:G", "chr1:200:C:T") + row <- FineMappingRow( + variantIds = ids, susieFit = list(), - topLoci = data.frame() + topLoci = data.frame(variant_id = ids, pip = c(0.7, 0.2)) ) - gr <- pecotmr:::.fmeTopLociGRanges(.fmrRowTopLoci(ent)) + gr <- as(row, "GRanges") expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 0) -}) - - -test_that(".fmrRowTopLoci() always returns the per-row table", { - tl <- data.frame( - variant_id = "1:100:A:G", - pip = 0.9, - betahat = 0.5, - sebetahat = 0.1, - cs = 1L, - stringsAsFactors = FALSE - ) - ent <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl + expect_identical(gr$pip, c(0.7, 0.2)) + x <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "t", + method = "susie", + entry = list(row) ) - expect_s3_class(.fmrRowTopLoci(ent), "data.frame") + expect_identical(unname(x[[1L]]), unname(gr)) }) # ============================================================================= -# extractBlockGenotypes returns RSE +# adjustPips: renormalize PIPs on a kept subset of variants # ============================================================================= test_that("adjustPips renormalizes PIPs on a kept FineMappingRow subset", { @@ -114,7 +45,6 @@ test_that("adjustPips renormalizes PIPs on a kept FineMappingRow subset", { expect_false(identical(unname(origPips[keep]), susieFit(adj)$pip)) }) - test_that("adjustPips errors when the intersection is empty", { vids <- paste0("chr1:", 1:4, ":A:G") entry <- .makeAdjustEntry(vids) @@ -124,7 +54,6 @@ test_that("adjustPips errors when the intersection is empty", { ) }) - test_that("adjustPips tolerates a chr-prefix difference between entry and keepVariants", { vids <- paste0("chr1:", 1:6, ":A:G") entry <- .makeAdjustEntry(vids) @@ -135,35 +64,12 @@ test_that("adjustPips tolerates a chr-prefix difference between entry and keepVa expect_equal(ncol(susieFit(adj)$lbf_variable), 4) }) - -test_that("adjustPips on a FineMappingResultBase collection renormalizes each entry", { - vidsA <- paste0("chr1:", 1:6, ":A:G") - vidsB <- paste0("chr1:", 3:8, ":A:G") - entryA <- .makeAdjustEntry(vidsA) - entryB <- .makeAdjustEntry(vidsB) - fmr <- QtlFineMappingResult( - studyName = c("s1", "s1"), - context = c("c1", "c2"), - trait = c("g1", "g1"), - method = c("susie", "susie"), - entry = list(entryA, entryB) - ) - # Keep only variants shared by both entries' raw sets. - keep <- intersect(vidsA, vidsB) - adj <- adjustPips(fmr, keep) - expect_s4_class(adj, "QtlFineMappingResult") - expect_equal(nrow(adj), 2L) - expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 1L)), keep) - expect_equal(variantIds(pecotmr:::.collectionEntry(adj, 2L)), keep) -}) - - # === Tests migrated from test_s4Constructors.R (FineMappingRow) === test_that("FineMappingRow: constructor stores slots and accessors return them", { tl <- .sc_makeTopLoci(3) tl$variant_id <- sprintf("chr9:%d:A:G", 100L * (1:3)) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = sprintf("chr9:%d:A:G", 100L * (1:3)), susieFit = list(payload = 1L), topLoci = tl @@ -179,7 +85,6 @@ test_that("FineMappingRow: constructor stores slots and accessors return them", expect_equal(out$variant_id, sprintf("chr9:%d:A:G", 100L * (1:3))) }) - test_that("FineMappingRow: pip returns named pip vector keyed by variant_id", { entry <- .sc_makeFineMappingRow(3) pip <- .fmrRowPip(entry) @@ -194,7 +99,7 @@ test_that("FineMappingRow: resolveWeights returns topLoci posterior effect align expect_equal(wr$weights, rep(0.05, 3)) expect_equal(length(wr$variantIds), length(wr$weights)) # empty topLoci -> empty pair - empty <- fineMappingRow( + empty <- FineMappingRow( variantIds = character(0), susieFit = list(), topLoci = data.frame( @@ -206,9 +111,8 @@ test_that("FineMappingRow: resolveWeights returns topLoci posterior effect align expect_length(.fmrRowResolveWeights(empty)$variantIds, 0L) }) - test_that("FineMappingRow: pip returns numeric(0) when topLoci is empty", { - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = character(0), susieFit = list(), topLoci = data.frame( @@ -220,14 +124,12 @@ test_that("FineMappingRow: pip returns numeric(0) when topLoci is empty", { expect_equal(.fmrRowPip(entry), numeric(0)) }) - test_that("FineMappingRow: credibleSets filters to rows in any credible set", { entry <- .sc_makeFineMappingRow(3) # last row has cs_95 = "susie_0" res <- .fmrRowCs(entry) expect_equal(nrow(res), 2L) }) - test_that("FineMappingRow: credibleSets/topLoci surface the directional af column", { # Regression: the posterior view must carry the topLoci `af` (effect-allele # frequency) through to .fmrRowCs() / .fmrRowTopLoci(), not drop it to NA. The @@ -243,10 +145,9 @@ test_that("FineMappingRow: credibleSets/topLoci surface the directional af colum expect_equal(unname(tl$af), rep(0.87, nrow(tl))) }) - test_that("FineMappingRow: validity errors when topLoci is missing required cols", { expect_error( - fineMappingRow( + FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame(other = 1, stringsAsFactors = FALSE) @@ -255,7 +156,6 @@ test_that("FineMappingRow: validity errors when topLoci is missing required cols ) }) - # === cvResult slot (cross-validation payload) === test_that("FineMappingRow stores and returns a cvResult payload", { @@ -269,7 +169,7 @@ test_that("FineMappingRow stores and returns a cvResult payload", { prediction = list(susie_predicted = matrix(0, 2, 1)), performance = list(susie_performance = matrix(0, 1, 6)) ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl, @@ -284,14 +184,14 @@ test_that("FineMappingRow cvResult defaults to NULL and rejects non-list", { pip = 0.5, stringsAsFactors = FALSE ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = tl ) expect_null(.fmrPartsCvResult(e)) expect_error( - fineMappingRow( + FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = tl, @@ -302,25 +202,9 @@ test_that("FineMappingRow cvResult defaults to NULL and rejects non-list", { }) # =========================================================================== -# TwasWeightsRow +# show(), credibleSets and adjustPips on one row # =========================================================================== -test_that("QtlFineMappingResult: rejects rows that are not row payloads", { - expect_error( - QtlFineMappingResult( - studyName = "s1", - context = "c1", - trait = "t1", - method = "susie", - entry = list("not_an_entry") - ), - "must be a fine-mapping row" - ) -}) - - -# === Tests migrated from test_showMethods.R (FineMappingRow) === - test_that("show.FineMappingRow reports variant count and CS count", { e_with_cs <- .sh_makeFmEntry(n = 3, with_cs = TRUE) # 2 distinct cs > 0 out <- capture.output(show(e_with_cs)) @@ -335,41 +219,31 @@ test_that("show.FineMappingRow reports variant count and CS count", { pip = c(0.1, 0.2), stringsAsFactors = FALSE ) - e_no_cs <- fineMappingRow( + e_no_cs <- FineMappingRow( variantIds = c("chr9:100:A:G", "chr9:200:A:G"), susieFit = list(), topLoci = tl ) out_no <- capture.output(show(e_no_cs)) expect_true(any(grepl("0 credible sets", out_no))) -}) - -# === marginalEffects maxPval filter === - -test_that("FineMappingRow: marginalEffects applies the maxPval filter", { - tl <- data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), - pip = c(0.9, 0.5, 0.1), - marginal_p = c(0.001, 0.5, NA_real_), - stringsAsFactors = FALSE - ) - entry <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl + # An empty row has no variants and so no sets. + empty <- FineMappingRow( + variantIds = character(0), + susieFit = list(pip = numeric(0)), + topLoci = data.frame( + variant_id = character(0), + pip = numeric(0), + stringsAsFactors = FALSE + ) ) - out <- .fmrRowMarginalEffects(entry, maxPval = 0.01) - # Drops the p = 0.5 row and the NA-p row; keeps only v1. - expect_equal(nrow(out), 1L) - expect_equal(out$variant_id, "chr1:100:A:G") + expect_output(show(empty), "0 variants, 0 credible sets") }) - # === credibleSets empty / cs-less topLoci projections === test_that("FineMappingRow: credibleSets returns empty posterior view when topLoci is empty", { - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = character(0), susieFit = list(), topLoci = data.frame( @@ -384,14 +258,13 @@ test_that("FineMappingRow: credibleSets returns empty posterior view when topLoc expect_true(all(c("variant_id", "pip") %in% names(res))) }) - test_that("FineMappingRow: credibleSets returns empty posterior view when the cs column is absent", { tl <- data.frame( variant_id = c("chr9:100:A:G", "chr9:200:A:G"), pip = c(0.1, 0.2), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = c("chr9:100:A:G", "chr9:200:A:G"), susieFit = list(), topLoci = tl @@ -401,7 +274,6 @@ test_that("FineMappingRow: credibleSets returns empty posterior view when the cs expect_equal(nrow(res), 0L) }) - # === adjustPips: missing alpha + mu2-driven posterior recompute === test_that("FineMappingRow: adjustPips errors when susieFit lacks alpha", { @@ -410,7 +282,7 @@ test_that("FineMappingRow: adjustPips errors when susieFit lacks alpha", { pip = c(0.6, 0.4), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), susieFit = list(), topLoci = tl @@ -421,7 +293,6 @@ test_that("FineMappingRow: adjustPips errors when susieFit lacks alpha", { ) }) - test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", { vids <- paste0("chr1:", 1:5, ":A:G") p <- length(vids) @@ -433,7 +304,7 @@ test_that("FineMappingRow: adjustPips subsets mu2 and recomputes posterior_sd", pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) mu <- matrix(rnorm(L * p), L, p) mu2 <- mu^2 + 1 # plausible second moment (>= mean^2) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = vids, susieFit = list( pip = pip, @@ -488,7 +359,7 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of ) attr(cst, "coverage") <- c(0.95, 0.70, 0.50) tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") - e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) # credibleSets: minPurity is orthogonal to coverage -> keeps only the pure CS members expect_equal(nrow(.fmrRowCs(e, coverage = 0.95)), 4L) @@ -505,7 +376,6 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of expect_equal(nrow(.fmrRowTopLoci(e, signalCutoff = 0)), 5L) # default (NULL) unchanged }) - # =========================================================================== # adjustPips: renormalize the stored alpha (prior-correct), reject # Omega-weighted fits, handle null_weight, and recompute credible sets @@ -534,7 +404,7 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of list( lbf = lbf, alpha = alpha, - entry = fineMappingRow( + entry = FineMappingRow( variantIds = vids, susieFit = list( pip = pip, @@ -589,7 +459,7 @@ test_that("adjustPips refuses an Omega-weighted (susieInf / susieAsh) fit", { entry <- .makeAdjustEntry(vids) fit <- .fmrPartsSusieFit(entry) fit$theta <- rep(0.1, length(vids)) - weighted <- fineMappingRow( + weighted <- FineMappingRow( variantIds = vids, susieFit = fit, topLoci = .fmrRowTopLoci(entry, raw = TRUE) @@ -606,7 +476,7 @@ test_that("adjustPips keeps the null_weight column in the renormalization", { raw <- matrix(runif(L * (p + 1)), L, p + 1) alpha <- raw / rowSums(raw) pip <- as.numeric(1 - apply(1 - alpha[, seq_len(p), drop = FALSE], 2, prod)) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = vids, susieFit = list(pip = pip, alpha = alpha, null_index = p + 1L), topLoci = data.frame( @@ -634,7 +504,7 @@ test_that("adjustPips errors when alpha's width matches neither variant count", entry <- .makeAdjustEntry(vids) fit <- .fmrPartsSusieFit(entry) fit$alpha <- cbind(fit$alpha, fit$alpha) - broken <- fineMappingRow( + broken <- FineMappingRow( variantIds = vids, susieFit = fit, topLoci = .fmrRowTopLoci(entry, raw = TRUE) @@ -642,6 +512,50 @@ test_that("adjustPips errors when alpha's width matches neither variant count", expect_error(adjustPips(broken, vids[1:3]), "8 columns but the entry has 4") }) +test_that("adjustPips restricts a narrowed row's fit by the fit's own ids", { + # The row holds variants 3:6 of the six its fit was made with. The kept + # ones are found among the fit's columns by id, not by their position in + # the row, which would pick the fit's columns 1:2. + vids <- paste0("chr1:", 1:6, ":A:G") + entry <- .makeAdjustEntry(vids) + narrowed <- methods::new( + "FineMappingRow", + variants = variants(entry)[3:6], + susieFit = susieFit(entry), + fitVariants = vids + ) + adj <- adjustPips(narrowed, vids[3:4]) + alpha <- susieFit(entry)$alpha[, 3:4] + expect_equal(variantIds(adj), vids[3:4]) + expect_equal(unname(susieFit(adj)$alpha), unname(alpha / rowSums(alpha))) + expect_equal(pecotmr:::.fmRowFitVariants(adj), vids[3:4]) +}) + +test_that("adjustPips refuses a row holding a variant its fit never had", { + fitted <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + expect_equal( + pecotmr:::.adjustPipsFitIdx(fitted[c(3L, 1L)], fitted), + c(3L, 1L) + ) + expect_error( + pecotmr:::.adjustPipsFitIdx(c(fitted[[1L]], "chr1:900:A:G"), fitted), + "1 of the row's variants are not among the 3 its fit was made with" + ) +}) + +test_that("a row records its fit's variants only when it carries a fit", { + vids <- paste0("chr1:", 1:3, ":A:G") + tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) + fitted <- FineMappingRow(vids, list(pip = tl$pip), tl) + expect_equal(pecotmr:::.fmRowFitVariants(fitted), vids) + cvOnly <- FineMappingRow(vids, NULL, tl, cvResult = list(r2 = 0.1)) + expect_equal(pecotmr:::.fmRowFitVariants(cvOnly), vids) + expect_equal( + pecotmr:::.fmRowFitVariants(FineMappingRow(vids, list(), tl)), + character(0) + ) +}) + test_that("adjustPips recomputes credible sets instead of remapping indices", { vids <- paste0("chr1:", 1:6, ":A:G") p <- length(vids) @@ -650,7 +564,7 @@ test_that("adjustPips recomputes credible sets instead of remapping indices", { lbf <- matrix(rnorm(L * p, sd = 3), L, p, dimnames = list(NULL, vids)) alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = vids, susieFit = list( pip = pip, @@ -699,7 +613,7 @@ test_that("adjustPips subsets mvsusie-shaped coef rows and 3-D clfsr", { fit <- .fmrPartsSusieFit(entry) fit$coef <- matrix(seq_len(p * R), nrow = p, ncol = R) fit$clfsr <- array(seq_len(L * p * R), dim = c(L, p, R)) - mv <- fineMappingRow( + mv <- FineMappingRow( variantIds = vids, susieFit = fit, topLoci = .fmrRowTopLoci(entry, raw = TRUE) @@ -715,16 +629,6 @@ test_that("adjustPips subsets mvsusie-shaped coef rows and 3-D clfsr", { ) }) -test_that(".fmrRowTopLoci(raw = TRUE) returns the stored table verbatim", { - vids <- paste0("chr1:", 1:4, ":A:G") - entry <- .makeAdjustEntry(vids) - raw <- .fmrRowTopLoci(entry, raw = TRUE) - expect_equal(nrow(raw), length(vids)) - expect_true(all(c("betahat", "sebetahat") %in% names(raw))) - # The default view filters by pip and projects; raw does neither. - expect_false(identical(names(raw), names(.fmrRowTopLoci(entry)))) -}) - # =========================================================================== # lbf (merged from test_getLbf.R when R/getLbf.R was folded # into R/FineMappingRow.R + R/AllClasses.R) @@ -741,7 +645,7 @@ test_that("lbf returns the wide variant x effect lbf matrix", { lbf_variable = lbf ) class(fit) <- "susie" - e <- fineMappingRow( + e <- FineMappingRow( variantIds = vids, susieFit = fit, topLoci = data.frame( @@ -758,7 +662,7 @@ test_that("lbf returns the wide variant x effect lbf matrix", { }) test_that("lbf is empty when the fit carries no lbf matrix", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), topLoci = data.frame( @@ -770,48 +674,6 @@ test_that("lbf is empty when the fit carries no lbf matrix", { expect_equal(nrow(.fmrRowLbf(e)), 0L) }) -test_that("lbf aggregates over a collection, carrying identity + NA-filling ragged effects", { - vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - mkEntry <- function(maxNumSingleEffects) { - lbf <- matrix( - seq_len(maxNumSingleEffects * length(vids)), - nrow = maxNumSingleEffects, - byrow = TRUE - ) # L x p - fit <- structure( - list(lbf_variable = lbf, pip = rep(0.3, length(vids))), - class = "susie" - ) - fineMappingRow( - variantIds = vids, - susieFit = fit, - topLoci = data.frame( - variant_id = vids, - pip = rep(0.3, length(vids)), - stringsAsFactors = FALSE - ) - ) - } - # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill of - # the ragged lbf_L columns described in the collection method's contract. - res <- QtlFineMappingResult( - studyName = c("s1", "s1"), - context = c("brain", "blood"), - trait = c("g", "g"), - method = c("susie", "susie"), - entry = list(mkEntry(2L), mkEntry(3L)) - ) - w <- lbf(res) - expect_true(all( - c("study", "context", "trait", "method", "variant_id") %in% names(w) - )) - expect_equal(nrow(w), 6L) # 2 entries x 3 variants - expect_setequal(unique(w$context), c("brain", "blood")) - expect_true("lbf_L3" %in% names(w)) - expect_true(all(is.na(w$lbf_L3[w$context == "brain"]))) # L = 2 entry: no effect 3 - expect_true(all(!is.na(w$lbf_L3[w$context == "blood"]))) # L = 3 entry: present -}) - # =========================================================================== # credibleSetSummary (merged from test_credibleSetSummary.R # when R/credibleSetSummary.R was folded in) @@ -858,7 +720,7 @@ test_that("credibleSetSummary returns one row per CS with size/purity/V/logBF/le ) attr(cst, "coverage") <- c(0.95, 0.70, 0.50) tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") - e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) s <- .fmrRowCredibleSetSummary(e) s <- s[order(s$cs), , drop = FALSE] @@ -900,7 +762,7 @@ test_that("credibleSetSummary is empty when there are no credible sets", { ) attr(cst, "coverage") <- c(0.95, 0.70, 0.50) tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") - e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) expect_equal(nrow(.fmrRowCredibleSetSummary(e)), 0L) }) @@ -916,7 +778,7 @@ test_that("credibleSetSummary is empty when the requested coverage column is abs cs_95_purity = c(0.9, 0.9), stringsAsFactors = FALSE ) - e <- fineMappingRow(variantIds = vn, susieFit = list(x = 1), topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = list(x = 1), topLoci = tl) expect_equal(nrow(.fmrRowCredibleSetSummary(e, coverage = 0.99)), 0L) }) @@ -932,7 +794,7 @@ test_that("credibleSetSummary reports NA cs_log_bf when the fit carries no lbf m cs_95_purity = c(0.88, 0.88), stringsAsFactors = FALSE ) - e <- fineMappingRow( + e <- FineMappingRow( variantIds = vn, susieFit = list(trimmed = TRUE), topLoci = tl @@ -957,102 +819,19 @@ test_that("credibleSetSummary reports NA cs_log_bf when the effect's lbf row is stringsAsFactors = FALSE ) fit <- structure(list(lbf_variable = lbf), class = "susie") - e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) expect_true(is.na(.fmrRowCredibleSetSummary(e)$cs_log_bf)) }) -test_that("credibleSetSummary aggregates across a collection with entry identity", { - mkEntry <- function() { - vn <- c("chr1:100:A:G", "chr1:200:C:T") - tl <- data.frame( - variant_id = vn, - pip = c(0.7, 0.2), - logBF = c(2.5, 0.3), - cs_95 = c("susie_1", "susie_1"), - cs_95_purity = c(0.9, 0.9), - stringsAsFactors = FALSE - ) - fineMappingRow(variantIds = vn, susieFit = list(x = 1), topLoci = tl) - } - res <- QtlFineMappingResult( - studyName = c("s", "s"), - context = c("brain", "blood"), - trait = c("g", "g"), - method = c("susie", "susie"), - entry = list(mkEntry(), mkEntry()) - ) - s <- credibleSetSummary(res) - expect_true(all( - c("study", "context", "trait", "method", "cs") %in% names(s) - )) - expect_equal(nrow(s), 2L) # one CS per entry - expect_setequal(unique(s$context), c("brain", "blood")) -}) - # =========================================================================== # fsusieCredibleBand / fsusieAffectedRegions (merged from # test_fsusieAccessors.R when R/fsusieAccessors.R was folded in) # =========================================================================== -.fsa_makeFit <- function(post_processing = "none") { - set.seed(1) - n <- 150L - p <- 24L - J <- 16L - X <- matrix( - rnorm(n * p), - n, - p, - dimnames = list( - paste0("s", seq_len(n)), - paste0("chr1:", seq_len(p) * 100, ":A:G") - ) - ) - b1 <- sin(seq(0, 2 * pi, length.out = J)) - b2 <- cos(seq(0, pi, length.out = J)) - Y <- X[, 3] %o% b1 + X[, 10] %o% b2 + matrix(rnorm(n * J, sd = 0.3), n, J) - colnames(Y) <- paste0("f", seq_len(J)) - suppressWarnings(fsusieR::susiF( - X = X, - Y = Y, - pos = seq_len(J), - L = 5, - post_processing = post_processing, - verbose = FALSE - )) -} -.fsa_entry <- function(fit, purityVal = 0.85) { - vids <- names(fit$csd_X) - pipv <- if (!is.null(fit$pip)) { - as.numeric(fit$pip) - } else { - rep(0.1, length(vids)) - } - # Canonical CS labels + purity from the fit's CS membership, mirroring what - # The fsusie post-processing writes into a real FMR's topLoci - # (cs_95 / cs_95_purity). - cs95 <- rep("fsusie_0", length(vids)) - for (l in seq_along(fit$cs)) { - idx <- fit$cs[[l]] - if (is.numeric(idx)) { - idx <- as.integer(idx) - } - cs95[idx] <- paste0("fsusie_", l) - } - tl <- data.frame( - variant_id = vids, - pip = pipv, - cs_95 = cs95, - cs_95_purity = ifelse(cs95 != "fsusie_0", purityVal, 0), - stringsAsFactors = FALSE - ) - fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) -} - test_that("fsusieCredibleBand returns a long effect + band table (lower <= effect <= upper)", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - cb <- .fmrRowFsusieCredibleBand(.fsa_entry(.fsa_makeFit())) + cb <- .fmrRowFsusieCredibleBand(.fsa_entry(.fsa_fits$none)) expect_named( cb, c("cs", "chrom", "pos", "effect", "lower", "upper", "halfwidth") @@ -1068,7 +847,7 @@ test_that("trimmed fSuSiE keeps curves, bands and coloc inputs", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") for (mode in c("none", "TI")) { - fit <- .fsa_makeFit(mode) + fit <- .fsa_fits[[mode]] expectedFit <- pecotmr:::.fsusiePopulateCredibleBand(fit) tables <- list(list(sets = list(cs = list()))) trimmed <- pecotmr:::trimFinemappingFit( @@ -1111,12 +890,11 @@ test_that("trimmed fSuSiE keeps curves, bands and coloc inputs", { } }) - test_that("fsusieAffectedRegions returns a GRanges with cs / purity / direction", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") gr <- .fmrRowFsusieAffectedRegions(.fsa_entry( - .fsa_makeFit(), + .fsa_fits$none, purityVal = 0.85 )) expect_s4_class(gr, "GRanges") @@ -1132,7 +910,7 @@ test_that("fsusieAffectedRegions returns a GRanges with cs / purity / direction" }) test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no wavelet slots)", { - e <- fineMappingRow( + e <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), topLoci = data.frame( @@ -1147,7 +925,7 @@ test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no # ---- fsusieTraitEffects --------------------------------------------- -# The pipeline stamps trait_positions onto the stored fit (jointEngine.R) and +# The pipeline records trait_positions on the stored fit (jointEngine.R) and # keeps the matching names in the row's jointTraits column; rebuild that pairing # here, since .fsa_makeFit() returns the raw susiF fit. .fsa_jointFit <- function(fit, pos) { @@ -1158,7 +936,7 @@ test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no test_that("fsusieTraitEffects evaluates the curve at each joint trait", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - fit <- .fsa_makeFit() + fit <- .fsa_fits$none nTrait <- length(fit$outing_grid) # Positions BETWEEN grid points, so the interpolation is doing real work. pos <- as.numeric(seq_len(nTrait)) + 0.5 @@ -1210,7 +988,7 @@ test_that("fsusieTraitEffects evaluates the curve at each joint trait", { test_that("fsusieTraitEffects refuses a fit whose positions and names disagree", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - fit <- .fsa_makeFit() + fit <- .fsa_fits$none res <- QtlFineMappingResult( studyName = "s", context = "brain", @@ -1231,7 +1009,7 @@ test_that("fsusieTraitEffects returns zero rows for a non-fsusie fit", { context = "brain", trait = "g", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5) @@ -1242,65 +1020,6 @@ test_that("fsusieTraitEffects returns zero rows for a non-fsusie fit", { expect_true(all(c("cs", "jointTrait", "traitPos", "effect") %in% names(te))) }) -test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collection", { - skip_if_not_installed("fsusieR") - skip_if_not_installed("wavethresh") - fit <- .fsa_makeFit() # deterministic; reuse for both rows - res <- QtlFineMappingResult( - studyName = c("s", "s"), - context = c("brain", "blood"), - trait = c("g", "g"), - method = c("fsusie", "fsusie"), - entry = list(.fsa_entry(fit), .fsa_entry(fit)) - ) - - cb <- fsusieCredibleBand(res) - expect_true(all( - c( - "study", - "context", - "trait", - "method", - "cs", - "effect", - "lower", - "upper" - ) %in% - names(cb) - )) - expect_gt(nrow(cb), 0) - expect_setequal(unique(cb$context), c("brain", "blood")) - - gr <- fsusieAffectedRegions(res) - expect_s4_class(gr, "GRanges") - expect_gt(length(gr), 0) - expect_true(all( - c("study", "context", "trait", "cs", "purity", "direction") %in% - names(S4Vectors::mcols(gr)) - )) - expect_setequal(unique(S4Vectors::mcols(gr)$context), c("brain", "blood")) -}) - -test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an empty GRanges", { - e <- fineMappingRow( - variantIds = "chr1:100:A:G", - susieFit = list(pip = 0.5), - topLoci = data.frame( - variant_id = "chr1:100:A:G", - pip = 0.5, - stringsAsFactors = FALSE - ) - ) - res <- QtlFineMappingResult( - studyName = "s", - context = "c", - trait = "t", - method = "susie", - entry = list(e) - ) - expect_equal(length(fsusieAffectedRegions(res)), 0L) -}) - test_that(".fsusieChrom returns NA when the fit has no named variants", { expect_true(is.na(pecotmr:::.fsusieChrom(list(csd_X = c(1, 2, 3))))) # unnamed expect_true(is.na(pecotmr:::.fsusieChrom(list()))) # no csd_X @@ -1329,7 +1048,7 @@ test_that(".fsusieCsMapFromTopLoci falls back to index labels when topLoci lacks list(fitted_wc2 = 1, fitted_func = list(1), outing_grid = 1:2, alpha = 1) } .fsa_bareEntry <- function() { - fineMappingRow( + FineMappingRow( variantIds = "chr1:100:A:G", susieFit = .fsa_fakeFit(), topLoci = data.frame( @@ -1434,7 +1153,7 @@ test_that("credibleSets warns when the coverage has no purity column to filter o # outside -- and a coverage with no sets returns earlier, so that route # cannot reach it either. tl$cs_95_purity <- NULL - e <- fineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vn, susieFit = fit, topLoci = tl) expect_warning( .fmrRowCs(e, coverage = 0.95, minPurity = 0.8), @@ -1455,7 +1174,7 @@ test_that("credibleSets warns when the coverage has no purity column to filter o test_that("topLoci must have one row per supplied variant", { vids <- .fmr_vids(3L) expect_error( - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(fake = TRUE), topLoci = data.frame( @@ -1473,7 +1192,7 @@ test_that("topLoci must list the variants in the same order", { # order check catches it. vids <- .fmr_vids(3L) expect_error( - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(fake = TRUE), topLoci = data.frame( @@ -1636,7 +1355,6 @@ test_that("a fit with no stored sets falls back to the per-variant column", { expect_equal(s$cs, "susie_1") }) - # =========================================================================== # Purity filtering, coverage defaults and column projection # =========================================================================== @@ -1668,11 +1386,6 @@ test_that("an unusable coverage falls back to 0.95", { expect_equal(pecotmr:::.adjustPipsCoverage(NULL), 0.95) }) -test_that("the credible-set prefix defaults to cs with no method column", { - tl <- tibble(variant_id = c("a", "b"), pip = c(0.1, 0.9)) - expect_equal(pecotmr:::.adjustPipsMethodLabel(tl), "cs") -}) - test_that("projecting an absent column yields typed NAs of the right length", { # One NA per row, of the requested type, so the column binds against the # rest of the table instead of collapsing it. @@ -1686,7 +1399,6 @@ test_that("projecting an absent column yields typed NAs of the right length", { expect_equal(pecotmr:::.tlCol(tl, "pip", "numeric"), c(0.1, 0.9)) }) - # =========================================================================== # Credible-set summary assembly and PIP adjustment # =========================================================================== @@ -1831,30 +1543,6 @@ test_that(".adjustPipsMethodLabel defaults to 'cs'", { ) }) -test_that("show(FineMappingRow) reports zero sets for an empty row", { - empty <- fineMappingRow( - variantIds = character(0), - susieFit = list(pip = numeric(0)), - topLoci = data.frame( - variant_id = character(0), - pip = numeric(0), - stringsAsFactors = FALSE - ) - ) - expect_output(show(empty), "0 variants, 0 credible sets") - withCs <- fineMappingRow( - variantIds = c("chr1:1:A:G", "chr1:2:C:T"), - susieFit = list(pip = c(0.9, 0.1)), - topLoci = data.frame( - variant_id = c("chr1:1:A:G", "chr1:2:C:T"), - pip = c(0.9, 0.1), - cs_95 = c("L1_1", "L1_0"), - stringsAsFactors = FALSE - ) - ) - expect_output(show(withCs), "2 variants, 1 credible sets") -}) - test_that(".csLog10Bf and .csMeanEffect return NA, never -Inf or NaN", { # Both previously disagreed with their own missing-column branch: an empty # or all-NA column yielded -Inf / NaN from max() / mean() while a missing @@ -1927,7 +1615,7 @@ test_that("an empty credible band still declares halfwidth", { # @noRd .fte_row <- function(fit) { - fineMappingRow( + FineMappingRow( variantIds = "chr1:100:A:G", susieFit = fit, topLoci = data.frame( @@ -2012,7 +1700,7 @@ test_that("a credible-set label matching no fit effect claims none", { }) test_that("a NULL posterior table projects to an empty GRanges", { - gr <- .fmeTopLociGRanges(NULL) + gr <- .variantTableGRanges(NULL) expect_s4_class(gr, "GRanges") expect_length(gr, 0L) }) @@ -2026,7 +1714,7 @@ test_that("a fit whose prior variances all vanished labels nothing", { colnames(lbf) <- vids alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = vids, susieFit = list( pip = pip, diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 048dc90b..8c3c4312 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -41,20 +41,21 @@ context("susie_finemapping") list(z = z, R = R, ids = ids, flipped = 6L) } -test_that("lbf_to_alpha_vector converts correctly", { - lbf <- c(a = -0.5, b = 1.2, c = 0.3) - alpha <- pecotmr:::lbfToAlphaVector(lbf) - expect_length(alpha, 3) - expect_equal(sum(alpha), 1, tolerance = 1e-10) - expect_true(alpha["b"] > alpha["a"]) -}) - -test_that("lbf_to_alpha_vector with prior weights", { - lbf <- c(a = 1, b = 1, c = 1) # Equal LBFs - pw <- c(0.5, 0.25, 0.25) - alpha <- pecotmr:::lbfToAlphaVector(lbf, priorWeights = pw) - expect_true(alpha[1] > alpha[2]) - expect_equal(sum(alpha), 1, tolerance = 1e-10) +test_that("lbf_to_alpha_vector normalizes moderate and extreme LBFs", { + # Very large and very negative values must neither overflow nor + # underflow to a degenerate posterior. + cases <- list( + moderate = c(a = -0.5, b = 1.2, c = 0.3), + large = c(a = 500, b = 500.1, c = 499), + negative = c(a = -1000, b = -999, c = -1001) + ) + for (nm in names(cases)) { + alpha <- pecotmr:::lbfToAlphaVector(cases[[nm]]) + expect_equal(length(alpha), 3L, info = nm) + expect_true(all(is.finite(alpha)), info = nm) + expect_equal(sum(alpha), 1, tolerance = 1e-10, info = nm) + expect_true(alpha["b"] > alpha["a"], info = nm) + } }) test_that("lbf_to_alpha_vector renormalizes an all-zero lbf to the prior", { @@ -93,30 +94,6 @@ test_that("lbf_to_alpha_vector handles single element", { expect_equal(alpha[["a"]], 1.0) }) -test_that("lbf_to_alpha_vector handles very large LBFs without overflow", { - lbf <- c(a = 500, b = 500.1, c = 499) - alpha <- pecotmr:::lbfToAlphaVector(lbf) - expect_true(all(is.finite(alpha))) - expect_equal(sum(alpha), 1, tolerance = 1e-10) - expect_true(alpha["b"] > alpha["a"]) -}) - -test_that("lbf_to_alpha_vector handles very negative LBFs", { - lbf <- c(a = -1000, b = -999, c = -1001) - alpha <- pecotmr:::lbfToAlphaVector(lbf) - expect_true(all(is.finite(alpha))) - expect_equal(sum(alpha), 1, tolerance = 1e-10) - expect_true(alpha["b"] > alpha["a"]) -}) - -test_that("lbf_to_alpha_vector with unequal prior weights", { - lbf <- c(a = 0.5, b = 0.5, c = 0.5) - pw <- c(0.8, 0.1, 0.1) - alpha <- pecotmr:::lbfToAlphaVector(lbf, priorWeights = pw) - expect_equal(sum(alpha), 1, tolerance = 1e-10) - expect_true(alpha[1] > 0.7) -}) - # ============================================================================= # lbfToAlpha (matrix version) # ============================================================================= @@ -145,15 +122,6 @@ test_that("lbfToAlpha handles single-row matrix", { expect_equal(sum(result), 1, tolerance = 1e-10) }) -test_that("lbfToAlpha handles large matrix", { - set.seed(42) - lbf <- matrix(rnorm(100), nrow = 10, ncol = 10) - colnames(lbf) <- sprintf("chr1:%d:A:G", 100L * (1:10)) - result <- lbfToAlpha(lbf) - expect_equal(dim(result), c(10, 10)) - expect_equal(rowSums(result), rep(1, 10), tolerance = 1e-10) -}) - test_that("lbfToAlpha with mixed zero and nonzero rows", { lbf <- matrix(c(0, 0, 0, 1, 2, 3), nrow = 2, byrow = TRUE) colnames(lbf) <- sprintf("chr1:%d:A:G", 100L * (1:3)) @@ -339,40 +307,92 @@ test_that("susieInfWeights returns zeros without proper fit structure", { expect_equal(result, rep(0, 5)) }) -# ============================================================================= -# glmnetWeights -# ============================================================================= - -test_that("glmnetWeights produces non-zero weights for correlated data", { - skip_if_not_installed("glmnet") - set.seed(42) - n <- 100 - p <- 10 - X <- matrix(rnorm(n * p), n, p) - beta_true <- c(3, -2, rep(0, p - 2)) - y <- X %*% beta_true + rnorm(n) - - w <- glmnetWeights(X, y, alpha = 0.5) - expect_length(w, p) - expect_true(any(w != 0)) -}) - -test_that("glmnetWeights handles zero-variance columns", { - skip_if_not_installed("glmnet") - set.seed(42) - n <- 100 +# ---- susieWeights ---- +test_that("susieWeights with alpha/mu/X_column_scale_factors calls coef.susie", { p <- 5 - X <- matrix(rnorm(n * p), n, p) - X[, 3] <- 1 # zero variance column - y <- X[, 1] * 2 + rnorm(n) + L <- 2 + mock_fit <- list( + alpha = matrix( + c( + 0.9, + 0.05, + 0.02, + 0.02, + 0.01, + 0.1, + 0.1, + 0.6, + 0.1, + 0.1 + ), + nrow = L, + ncol = p, + byrow = TRUE + ), + mu = matrix( + c( + 2.0, + 0.1, + 0.05, + 0.03, + 0.01, + 0.5, + 0.2, + 1.5, + 0.1, + 0.05 + ), + nrow = L, + ncol = p, + byrow = TRUE + ), + X_column_scale_factors = rep(1.0, p), + pip = runif(p), + intercept = 0 + ) + result <- susieWeights(susieFit = mock_fit) + expect_length(result, p) + expect_true(is.numeric(result)) + expect_true(any(result != 0)) +}) + +# ---- susieAshWeights / susieInfWeights ---- +# The fit is each extractor's third argument (susieAshFit / susieInfFit). +test_that("susieAshWeights / susieInfWeights error on dimension mismatch", { + mock_fit <- list(pip = c(0.1, 0.2)) + X <- matrix(rnorm(30), nrow = 10, ncol = 3) + for (fn in c("susieAshWeights", "susieInfWeights")) { + expect_error( + exec(fn, X, NULL, mock_fit), + "Dimension mismatch", + info = fn + ) + } +}) - w <- glmnetWeights(X, y, alpha = 1) - expect_length(w, p) - expect_equal(w[3], 0) +test_that("susieAshWeights / susieInfWeights add theta to the sparse part", { + # The weights are coef.susie() without its intercept: the mappable + # effect colSums(alpha * mu) plus the fit's theta, on the X scale. + p <- 4 + L <- 2 + set.seed(5) + fit <- list( + alpha = matrix(runif(L * p), nrow = L, ncol = p), + mu = matrix(rnorm(L * p), nrow = L, ncol = p), + theta = rnorm(p), + X_column_scale_factors = c(1, 2, 0.5, 1), + pip = runif(p), + intercept = 0.7 + ) + want <- (colSums(fit$alpha * fit$mu) + fit$theta) / + fit$X_column_scale_factors + for (fn in c("susieAshWeights", "susieInfWeights")) { + expect_equal(exec(fn, NULL, NULL, fit), want, info = fn) + } }) # ============================================================================= -# postprocessFinemappingFits: analysisScript and V=NULL branches (Tier 1) +# postprocessFinemappingFits: V = NULL branch # ============================================================================= # Helper: build a minimal synthetic SuSiE-family output for post-processing @@ -491,7 +511,7 @@ test_that("formatFinemappingOutput does not duplicate top loci variants", { stringsAsFactors = FALSE ) vids <- sprintf("chr1:%d:A:G", 100L * (1:4)) - fm <- fineMappingRow( + fm <- FineMappingRow( variantIds = vids, susieFit = list(pip = 1:4), topLoci = data.frame( @@ -572,36 +592,9 @@ test_that(".translate_legacy_top_loci_cs_columns leaves existing pip column alon # ============================================================================ -# Unified top-loci: hard gating coverage per OpenSpec tasks 4.27 / 4.28. -# These tests are the implementation gate for the buildTopLoci migration. +# Unified top-loci (buildTopLoci): schema, CS columns and coverage handling # ============================================================================ -# Reuse the existing local helper. Re-declared inside this block so the file -# remains correct whether the unified-section tests are run alone or as part of -# the full file. -if (!exists(".makeUnivariateData", inherits = FALSE)) { - .makeUnivariateData <- function( - seed = 42, - n = 300, - p = 50, - effect_idx = integer(0), - effect_size = NULL - ) { - set.seed(seed) - X <- matrix(rnorm(n * p), n, p) - colnames(X) <- sprintf("chr1:%d:G:A", seq_len(p)) - beta <- rep(0, p) - if (length(effect_idx) > 0) { - if (is.null(effect_size)) { - effect_size <- rep(1.5, length(effect_idx)) - } - beta[effect_idx] <- effect_size - } - y <- as.numeric(X %*% beta) + rnorm(n, sd = 0.5) - list(X = X, y = y) - } -} - .UNIFIED_TOP_LOCI_COLS <- c( "variant_id", "chrom", @@ -929,28 +922,38 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { expect_false(any(c("conditional_effect", "lfsr") %in% names(tl0))) }) -test_that("topLoci surfaces the mvsusie lfsr through the projector", { - tl <- data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - chrom = "1", - pos = c(100L, 200L), - A1 = c("A", "C"), - A2 = c("G", "T"), - pip = c(0.6, 0.4), - posterior_mean = c(0.1, 0.2), - posterior_sd = c(0.05, 0.05), - cs_95 = c("mvsusie_1", "mvsusie_1"), - lfsr = c(0.001, 0.02), - stringsAsFactors = FALSE +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" ) - e <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(pip = tl$pip), - topLoci = tl + 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" ) - out <- .fmrRowTopLoci(e, signalCutoff = 0) - expect_true(is_in("lfsr", names(out))) - expect_equal(out$lfsr, c(0.001, 0.02)) + expect_true(all(tl$posterior_theta == 0)) + expect_false(anyNA(tl$posterior_theta)) }) test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcoded 0.95/0.70/0.50)", { @@ -1017,7 +1020,7 @@ test_that("buildTopLoci: per-variant logBF is the max single-effect lbf", { expect_true("logBF" %in% names(tl)) expect_equal(tl$logBF, apply(lbf, 2, max)) # c(2.0, 3.0, 0.2) # surfaced through topLoci's projection too - e <- fineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) + e <- FineMappingRow(variantIds = vids, susieFit = fit, topLoci = tl) expect_true("logBF" %in% names(.fmrRowTopLoci(e, signalCutoff = 0))) }) @@ -1030,8 +1033,7 @@ test_that("buildTopLoci emits the fixed columns in order on a non-empty fit", { "0.7" = list(c(1L, 2L)), "0.5" = list(c(1L, 2L)) ), - nSamples = 419, - n_variants = 11332 + nSamples = 419 ) other_q <- list(condition_id = "Ast_DeJager_eQTL") out <- .runBuildTopLoci( @@ -1040,7 +1042,7 @@ test_that("buildTopLoci emits the fixed columns in order on a non-empty fit", { sumstats = list(betahat = c(0.2, -0.1), sebetahat = c(0.05, 0.04)), af = c(0.10, 0.25), otherQuantities = other_q, - region = "chr10:10823338-14348298" + region = GenomicRanges::GRanges("chr10:10823338-14348298") ) expect_equal(names(out), .UNIFIED_TOP_LOCI_COLS) expect_equal(unique(out$gene), "ENSG00000179403") @@ -1367,30 +1369,6 @@ test_that("postprocessFinemappingFits forwards medianAbsCorr to susie_get_cs (OR expect_gte(.n_cs95(pOr), .n_cs95(pStrict)) }) -test_that("postprocessFinemappingFits with medianAbsCorr = NULL is a no-op", { - d <- .makeUnivariateData(seed = 7, effect_idx = c(20)) - fit <- susieR::susie(d$X, d$y, L = 5) - p1 <- postprocessFinemappingFits( - list(susie = fit), - dataX = d$X, - dataY = d$y, - credibleSetParam = CredibleSetParam( - coverage = 0.95 - ) - ) - p2 <- postprocessFinemappingFits( - list(susie = fit), - dataX = d$X, - dataY = d$y, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - medianAbsCorr = NULL - ) - ) - expect_equal(p1$top_loci$cs_95, p2$top_loci$cs_95) - expect_equal(p1$top_loci$af, p2$top_loci$af) -}) - test_that("cs_95 / cs_70 / cs_50 are character strings of the form '_'", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:T:C") # Variants 1 and 2 in CS 1 (at 95), variant 3 in CS 2 (at 95). All three @@ -1459,6 +1437,8 @@ test_that("per-method CS indices are independent across susie and susieInf (post has_susie_inf_1 <- any(susie_inf_rows$cs_95 == "susie_inf_1") expect_true(has_susie_1 || nrow(susie_rows) == 0L) expect_true(has_susie_inf_1 || nrow(susie_inf_rows) == 0L) + # A variant both methods report gets one row per method, never two. + expect_equal(anyDuplicated(tl[, c("variant_id", "method")]), 0L) }) test_that("cs_95_purity = 0 when cs_95 is '_0', and in (0, 1] otherwise", { @@ -1499,40 +1479,6 @@ test_that("overlapping CS within one method: one row per variant; smallest cs_id expect_equal(out$cs_95, "susie_1") }) -test_that("overlapping CS across methods produces one row per method", { - d <- .makeUnivariateData(seed = 22, effect_idx = c(12, 32)) - fits <- fitSusieInfThenSusie(d$X, d$y) - post <- postprocessFinemappingFits( - fits, - dataX = d$X, - dataY = d$y, - credibleSetParam = CredibleSetParam( - coverage = 0.95, - secondaryCoverage = c(0.7, 0.5) - ) - ) - tl <- post$top_loci - if (nrow(tl) > 0L) { - cnt_per_method <- table(tl$variant_id, tl$method) - shared <- rownames(cnt_per_method)[ - apply(cnt_per_method > 0, 1, sum) >= 2L - ] - if (length(shared) > 0L) { - v <- shared[[1]] - rows_for_v <- tl[tl$variant_id == v, , drop = FALSE] - expect_gte(length(unique(rows_for_v$method)), 2L) - } else { - succeed( - "no shared variants in this fixture; cross-method uniqueness rule is structural" - ) - } - } else { - succeed( - "empty top_loci from this fixture; cross-method uniqueness rule is structural" - ) - } -}) - test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_loci_long, no wide top_loci, no top_loci_export", { d <- .makeUnivariateData(seed = 23, effect_idx = c(15, 40)) fits <- fitSusieInfThenSusie(d$X, d$y) @@ -1548,7 +1494,7 @@ test_that("formatFinemappingOutput exposes exactly one top_loci field; no top_lo expect_true("top_loci" %in% names(out)) expect_false("top_loci_long" %in% names(out)) expect_false("top_loci_export" %in% names(out)) - # The exposed top_loci has the unified 22-column schema. + # The exposed top_loci has the unified schema. expect_equal(names(out$top_loci), .UNIFIED_TOP_LOCI_COLS) }) @@ -1575,57 +1521,6 @@ test_that("postprocessFinemappingFits does not return top_loci_long anywhere", { } }) -test_that("build_top_loci_long / build_top_loci_wide / build_top_loci_export are removed from the package", { - # Two layered checks. (1) The new helper must be reachable. (2) The old - # helpers must NOT be reachable — neither in the package namespace (if the - # package is installed) nor in .GlobalEnv (when this file is source-loaded - # against the fresh R/ tree for testing). The contract is that the trio is - # gone end-to-end after the migration. - resolve <- function(name) { - if (exists(name, envir = .GlobalEnv, inherits = FALSE)) { - return(get(name, envir = .GlobalEnv)) - } - ns_ok <- tryCatch(asNamespace("pecotmr"), error = function(e) NULL) - if (!is.null(ns_ok) && exists(name, envir = ns_ok, inherits = FALSE)) { - return(get(name, envir = ns_ok)) - } - NULL - } - expect_false( - is.null(resolve("buildTopLoci")), - info = "buildTopLoci must be defined after the migration" - ) - # The removed trio: only fail if a definition exists in the SAME source - # tree we just loaded (i.e. globalenv). The installed-package namespace - # may still carry stale copies from an earlier install; the gate only - # cares that the new source tree does not redefine them. - expect_false(exists( - "build_top_loci_long", - envir = .GlobalEnv, - inherits = FALSE - )) - expect_false(exists( - "build_top_loci_wide", - envir = .GlobalEnv, - inherits = FALSE - )) - expect_false(exists( - "build_top_loci_export", - envir = .GlobalEnv, - inherits = FALSE - )) - expect_false(exists( - ".emptyTopLoci_long", - envir = .GlobalEnv, - inherits = FALSE - )) - expect_false(exists( - ".emptyTopLoci_export", - envir = .GlobalEnv, - inherits = FALSE - )) -}) - test_that("buildTopLoci raises an explicit error on invalid variant_id rather than silently filling NA", { variant_ids <- c("not_a_valid_id") cs_at_cov <- list("0.95" = list(1L), "0.7" = list(1L), "0.5" = list(1L)) @@ -1678,7 +1573,7 @@ test_that("missing region produces NA grange columns rather than silent omission method = "susie", otherQuantities = list(condition_id = "ctx") ) - # grange_* must still be present columns of the 22-col schema, with NA values. + # grange_* must still be present columns of the schema, with NA values. expect_true(all(c("grange_start", "grange_end") %in% names(out))) expect_true(all(is.na(out$grange_start))) expect_true(all(is.na(out$grange_end))) @@ -2047,22 +1942,25 @@ test_that(".asLbfMatrix prefers lbf_variable, falls back to lBF, else NULL", { }) # ---- .parseGrange ---- -test_that(".parseGrange returns NA for NULL/empty/invalid and parses valid regions", { +test_that(".parseGrange reads a window's bounds, NA without one", { expect_equal( pecotmr:::.parseGrange(NULL), c(start = NA_integer_, end = NA_integer_) ) expect_equal( - pecotmr:::.parseGrange(""), + pecotmr:::.parseGrange(GenomicRanges::GRanges()), c(start = NA_integer_, end = NA_integer_) ) expect_equal( - pecotmr:::.parseGrange("not_a_region"), - c(start = NA_integer_, end = NA_integer_) + pecotmr:::.parseGrange(GenomicRanges::GRanges( + "chr10:10823338-14348298" + )), + c(start = 10823338L, end = 14348298L) ) - expect_equal( + # A window is a GRanges; a string is refused rather than read. + expect_error( pecotmr:::.parseGrange("chr10:10823338-14348298"), - c(start = 10823338L, end = 14348298L) + "`region` must be a GRanges" ) }) @@ -2708,7 +2606,7 @@ test_that("susieRssWeights retains fit unless fitRetention is none", { expect_false(is.null(attr(w, "fit"))) }) -test_that("susieInfRssWeights works", { +test_that("susieInfRssWeights adds the fit's infinitesimal theta", { skip_if_not_installed("susieR") set.seed(42) p <- 20 @@ -2716,42 +2614,58 @@ test_that("susieInfRssWeights works", { R <- diag(p) z <- rnorm(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, .rrwLdMatrix(R), susieInfRssFit = fit) - expect_equal(length(w), p) - expect_true(all(is.finite(w))) -}) - -test_that("mvsusieWeights real fit returns p x K weights or errors on unstable small data", { - skip_if_not_installed("mvsusieR") - m <- .rrwMulti(n = 80, p = 8, K = 2) - res <- tryCatch( - suppressMessages(mvsusieWeights(X = m$X, Y = m$Y, L = 5, LGreedy = 2)), - error = function(e) e - ) - if (inherits(res, "error")) { - # mvSuSiE can be numerically unstable on tiny (X, Y); a clean error is - # acceptable here. The coef-extraction path is covered by the mocked tests - # in test_rrMrmashMvsusie.R. - succeed("mvsusieWeights errored on small data (documented instability)") - } else { - expect_equal(dim(res), c(m$p, m$K)) - expect_true(all(is.finite(res))) - } + # The fit fineMappingPipeline() makes for susieInf: it carries theta, the + # infinitesimal effects. A plain susie_rss() fit has no theta, and the + # extractor returns all-zero weights for it. + fit <- suppressMessages(susieR::susie_rss( + z = z, + R = R, + n = n, + L = 5, + unmappable_effects = "inf" + )) + expect_true(any(fit$theta != 0)) + w <- susieInfRssWeights( + stat, + .rrwLdMatrix(R), + susieInfRssFit = fit, + fitRetention = "none" + ) + # coef.susie(): the sparse alpha * mu effects plus theta, divided by the + # scale factors. theta is a one-column matrix; the weights are a vector. + expect_equal( + w, + (colSums(fit$alpha * fit$mu) + drop(fit$theta)) / + fit$X_column_scale_factors + ) }) -test_that("susieAshRssWeights returns weights of length p", { +test_that("susieAshRssWeights adds the fit's ash theta", { skip_if_not_installed("susieR") f <- .rrwStatLd() - fit <- susieR::susie_rss( + # The fit fineMappingPipeline() makes for susieAsh: it carries theta, the + # ash-shrunk unmappable effects. A plain susie_rss() fit has no theta, + # and the extractor returns all-zero weights for it. + fit <- suppressMessages(susieR::susie_rss( z = f$stat$z, R = f$LD, n = median(f$stat$n), - L = 5 + L = 5, + unmappable_effects = "ash" + )) + expect_true(any(fit$theta != 0)) + w <- susieAshRssWeights( + f$stat, + f$ldReference, + susieAshRssFit = fit, + fitRetention = "none" + ) + # coef.susie(): the sparse alpha * mu effects plus theta, divided by the + # scale factors. + expect_equal( + w, + (colSums(fit$alpha * fit$mu) + fit$theta) / fit$X_column_scale_factors ) - w <- susieAshRssWeights(f$stat, f$ldReference, susieAshRssFit = fit) - expect_length(w, f$p) - expect_true(all(is.finite(w))) }) test_that("mvsusieRssWeights returns p x K weights from a supplied fit", { @@ -2822,15 +2736,6 @@ test_that("mvsusieRssWeights checks the fit against the statistics' block", { ) }) -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$ldReference), - "`mvsusieRssFit` is required" - ) -}) - test_that("mvsusieRssWeights demands a fit before anything else", { skip_if_not_installed("mvsusieR") f <- .rrwStatLd() @@ -2922,10 +2827,19 @@ test_that("mvsusieWeights returns coefficients from provided fit", { ) } +# One fit at the default prior serves every test below that uses it: each +# susiF() fit takes about a second. +.fw_fsusieDefault <- if ( + requireNamespace("fsusieR", quietly = TRUE) && + requireNamespace("wavethresh", quietly = TRUE) +) { + .fw_makeFsusieFit() +} + test_that("fsusieWeights returns a variants x features matrix with variant rownames", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - obj <- .fw_makeFsusieFit() + obj <- .fw_fsusieDefault W <- fsusieWeights(fsusieFit = obj$fit, variantIds = colnames(obj$X)) expect_true(is.matrix(W)) expect_equal(nrow(W), ncol(obj$X)) @@ -2936,7 +2850,7 @@ test_that("fsusieWeights returns a variants x features matrix with variant rowna test_that("computeCsTable (fsusie): within-CS purity, not cal_cor_cs", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - obj <- .fw_makeFsusieFit() + obj <- .fw_fsusieDefault ct <- computeCsTable(obj$fit, obj$X, coverage = 0.95, csInput = "fsusie") # purity is recorded as min.abs.corr, the susieR-path shape that # .csPurityVec reads @@ -2954,7 +2868,7 @@ test_that("computeCsTable (fsusie): within-CS purity, not cal_cor_cs", { test_that("fsusieWeights matches fsusieR's own out_prep reconstruction (post_processing='none')", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - obj <- .fw_makeFsusieFit() + obj <- .fw_fsusieDefault fit <- obj$fit # The alpha-weighted sum over SNPs of the per-SNP feature-domain curves that # fsusieWeights reconstructs must equal fSuSiE's own fitted_func[[l]] (built @@ -2985,7 +2899,7 @@ test_that("fsusieWeights matches fsusieR's own out_prep reconstruction (post_pro test_that("fsusieWeights concentrates weight on the causal SNPs", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - obj <- .fw_makeFsusieFit() + obj <- .fw_fsusieDefault W <- fsusieWeights(fsusieFit = obj$fit, variantIds = colnames(obj$X)) rowNorm <- sqrt(rowSums(W^2)) top2 <- names(sort(rowNorm, decreasing = TRUE))[1:2] @@ -3024,7 +2938,7 @@ test_that("fsusieWeights errors without a fit and on an unusable (trimmed, no co .msc_entry <- function(vid, pip, cs, csName = "cs_95") { tl <- data.frame(variant_id = vid, pip = pip, stringsAsFactors = FALSE) tl[[csName]] <- cs - fineMappingRow(variantIds = vid, susieFit = list(), topLoci = tl) + FineMappingRow(variantIds = vid, susieFit = list(), topLoci = tl) } .msc_fmr <- function(entries, method = "susie") { n <- length(entries) @@ -3110,7 +3024,7 @@ test_that("mergeSusieCs: a condition with no usable CS is skipped, valid ones ke c(0.9, 0.8), c("susie_1", "susie_1") ) - noCs <- fineMappingRow( + noCs <- FineMappingRow( variantIds = "chr1:300:A:G", susieFit = list(), topLoci = data.frame(variant_id = "chr1:300:A:G", pip = 0.9) @@ -3126,7 +3040,7 @@ test_that("mergeSusieCs: NULL when no condition contributes a credible set", { 0.9, "susie_0" ))))) # all _0 - noCs <- fineMappingRow( + noCs <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.9) @@ -3167,7 +3081,7 @@ test_that("mergeSusieCs: input that is not a fine-mapping result errors", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = vids, susieFit = list(sets = list(cs = cs), pip = pip), topLoci = data.frame( @@ -3182,13 +3096,17 @@ test_that("mergeSusieCs: input that is not a fine-mapping result errors", { test_that("computeCsCorrelation (SumStats) matches get_cs_correlation", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldReference(ss)) + vids <- rownames(ldReference(ss)[[1L]]) 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:::.ldFromRef(ldReference(ss), vids, onMissing = "error") + xcorr <- pecotmr:::.ldFromRef( + ldReference(ss)[[1L]], + vids, + onMissing = "error" + ) ref <- susieR::get_cs_correlation( list(sets = susieFit(fe)$sets, pip = susieFit(fe)$pip), Xcorr = xcorr @@ -3202,7 +3120,7 @@ test_that("computeCsCorrelation reads a panel's factor or an LdMatrix alike", { # same LD gives the same between-CS correlation. data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example - panel <- ldReference(gss) + panel <- ldReference(gss)[[1L]] withLd <- GwasSumStats( studyName = studyName(gss), entry = list(pecotmr:::.collectionEntry(gss, 1L)), @@ -3211,7 +3129,7 @@ test_that("computeCsCorrelation reads a panel's factor or an LdMatrix alike", { unname(computeLd(panel)), variants = SummarizedExperiment::rowRanges(panel) ), - qcInfo = qcInfo(gss) + qcOptions = qcOptions(gss) ) vids <- names(SummarizedExperiment::rowRanges(panel))[1:40] set.seed(3) @@ -3231,7 +3149,7 @@ test_that("computeCsCorrelation reads a panel's factor or an LdMatrix alike", { context = "c1", trait = "t1", method = "fsusie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = vids, susieFit = structure(list(cs = cs, pip = pip), class = "susiF"), topLoci = data.frame( @@ -3255,11 +3173,11 @@ test_that("computeCsCorrelation reads an fSuSiE fit's sets, from LD", { # latter made every fSuSiE fit look set-less, so this came back NULL. data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldReference(ss)) + vids <- rownames(ldReference(ss)[[1L]]) 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") + R <- pecotmr:::.ldFromRef(ldReference(ss)[[1L]], vids, onMissing = "error") expect_equal(cc, .ccMaxCorrelation(R, cs)) expect_equal(diag(cc), c(1, 1)) }) @@ -3280,7 +3198,7 @@ test_that("computeCsCorrelation reads an fSuSiE fit's sets, from genotypes", { test_that("computeCsCorrelation is NULL for fewer than two credible sets", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldReference(ss)) + vids <- rownames(ldReference(ss)[[1L]]) set.seed(1) expect_null(computeCsCorrelation(.ccMakeEntry(vids, list()), ss)) expect_null( @@ -3290,7 +3208,7 @@ test_that("computeCsCorrelation is NULL for fewer than two credible sets", { test_that("computeCsCorrelation requires a QtlDataset / SumStats ldSource", { data(qtlSumStatsExample) - vids <- rownames(ldReference(qtlSumStatsExample)) + vids <- rownames(ldReference(qtlSumStatsExample)[[1L]]) set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) expect_error(computeCsCorrelation(fe, 42), "requires a QtlDataset") @@ -3303,7 +3221,7 @@ 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(ldReference(ss)) + vids <- rownames(ldReference(ss)[[1L]]) vids[1] <- "chr22:99999999:A:G" set.seed(1) fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(90L, 91L))) @@ -3374,18 +3292,12 @@ test_that("disjoint sets neither warn nor relabel", { expect_equal(eff, c(1L, 1L, 1L, 2L, 2L, 0L)) }) -test_that(".fmEffectIndices parses L-names and falls back to position", { - expect_equal(.fmEffectIndices(list(L1 = 1, L2 = 2, L7 = 3)), c(1L, 2L, 7L)) - expect_equal(.fmEffectIndices(list(1, 2, 3)), c(1L, 2L, 3L)) -}) - context("post_finemapping_cs_extraction") -# A single-row QtlFineMappingResult standing in for the retired -# FineMappingRow. topLoci defaults to one row per variant: the row-payload -# builder requires the two to be aligned, where the entry tolerated an empty -# table beside a non-empty variant list. +# A single-row QtlFineMappingResult wrapping one FineMappingRow. topLoci +# defaults to one row per variant: the row-payload builder requires the two +# to be aligned. .testFineMappingRow <- function( variantIds, susieFit = list(), @@ -3403,7 +3315,7 @@ context("post_finemapping_cs_extraction") context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = variantIds, susieFit = susieFit, topLoci = topLoci @@ -3415,22 +3327,12 @@ context("post_finemapping_cs_extraction") # susieResult # =========================================================================== -test_that("susieResult returns NULL for empty input", { - result <- susieResult(list()) - expect_null(result) -}) - -test_that("susieResult returns NULL when finemappingEntry missing", { - result <- susieResult(list(some_data = 42)) - 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( + row <- FineMappingRow( variantIds = ids, susieFit = fit, topLoci = data.frame(variant_id = ids, pip = c(0.2, 0.8)) @@ -3450,6 +3352,21 @@ test_that("susieResult returns trimmed result when present", { expect_equal(result, mock_result) }) +test_that("susieResult warns about a narrowed entry and returns its fit", { + fit <- list(pip = c(0.1, 0.5, 0.3), sets = list(cs = list())) + fe <- .testFineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), + susieFit = fit + ) + expect_warning( + out <- susieResult(list( + finemappingEntry = endoapply(fe, utils::head, 2L) + )), + "susieResult\\(\\): the stored fit was made with 3 variants" + ) + expect_equal(out, fit) +}) + # =========================================================================== # extractTopPipInfo # =========================================================================== @@ -3466,24 +3383,12 @@ test_that("extractTopPipInfo finds top PIP variant", { expect_equal(result$top_variant, "chr1:200:C:T") expect_equal(result$top_pip, 0.7) expect_equal(result$top_z, 3.5) + expect_equal(result$p_value, pecotmr:::.zToPvalue(3.5)) expect_equal(result$top_variant_index, 2) expect_true(is.na(result$cs_name)) expect_true(is.na(result$variants_per_cs)) }) -test_that("extractTopPipInfo computes p_value from z", { - con_data <- list( - finemappingEntry = .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), - susieFit = list(pip = c(0.9, 0.05, 0.05)) - ), - sumstats = list(z = c(5.0, 0.5, -0.3)) - ) - result <- extractTopPipInfo(con_data$finemappingEntry, con_data$sumstats) - expected_pval <- pecotmr:::.zToPvalue(5.0) - expect_equal(result$p_value, expected_pval) -}) - test_that("extractTopPipInfo handles ties by taking first max", { con_data <- list( finemappingEntry = .testFineMappingRow( @@ -3526,6 +3431,7 @@ test_that("extractCsInfo extracts single CS correctly", { expect_equal(result$top_variant, "chr1:200:C:T") expect_equal(result$top_pip, 0.8) expect_equal(result$variants_per_cs, 2) + expect_equal(result$p_value, pecotmr:::.zToPvalue(4.5), tolerance = 1e-10) expect_true(is.na(result$cs_corr_max)) expect_true(is.na(result$cs_corr_min)) expect_false("cs_corr_1" %in% colnames(result)) @@ -3534,7 +3440,7 @@ test_that("extractCsInfo extracts single CS correctly", { test_that("extractCsInfo builds correlation columns from the ldSource", { data(qtlSumStatsExample) ss <- qtlSumStatsExample - vids <- rownames(ldReference(ss)) + vids <- rownames(ldReference(ss)[[1L]]) set.seed(1) fit <- list( sets = list(cs = list(L_1 = c(1L, 2L, 3L), L_2 = c(90L, 91L))), @@ -3571,26 +3477,60 @@ test_that("extractCsInfo builds correlation columns from the ldSource", { expect_equal(result$cs_corr_min, rep(abs(cc[1, 2]), 2)) }) -test_that("extractCsInfo computes p_value from z-score", { +test_that("extractCsInfo names a narrowed row's sets by the fit's variants", { + # The set indices point into the variables the fit was made with. Named + # by the variants the narrowed row holds instead, they would land one + # variant off. data(qtlSumStatsExample) + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A", "chr1:400:T:C") + pip <- c(0.1, 0.6, 0.2, 0.1) + tl <- data.frame(variant_id = vids, pip = pip, z = c(1, 4, 2, 0.5)) fe <- .testFineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:C:T"), - susieFit = list(sets = list(cs = list(L_1 = c(1, 2)))) + variantIds = vids, + susieFit = list(pip = pip, sets = list(cs = list(L_1 = c(2L, 3L)))), + topLoci = tl ) - top_loci_table <- data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:C:T"), - pip = c(0.9, 0.1), - z = c(5.0, 0.5), - stringsAsFactors = FALSE + narrowed <- endoapply(fe, utils::tail, 3L) + expect_warning( + out <- extractCsInfo( + narrowed, + csNames = "L_1", + topLociTable = tl, + ldSource = qtlSumStatsExample + ), + "extractCsInfo\\(\\): the stored fit was made with 4 variants" ) - result <- extractCsInfo( - fe, - csNames = "L_1", - topLociTable = top_loci_table, - ldSource = qtlSumStatsExample + expect_equal(out$top_variant, "chr1:200:C:T") + expect_equal(out$variants_per_cs, 2L) + expect_equal(out$top_variant_index, 2L) + expect_warning( + top <- extractTopPipInfo(narrowed, sumstats = list(z = tl$z)), + "extractTopPipInfo\\(\\)" ) - expected_pval <- pecotmr:::.zToPvalue(5.0) - expect_equal(result$p_value, expected_pval, tolerance = 1e-10) + expect_equal(top$top_variant, "chr1:200:C:T") + expect_equal(top$top_z, 4) +}) + +test_that("computeCsCorrelation of a narrowed row warns, on the fit's sets", { + data(qtlSumStatsExample) + ss <- qtlSumStatsExample + vids <- rownames(ldReference(ss)[[1L]]) + fe <- .testFineMappingRow( + variantIds = vids, + susieFit = list( + sets = list(cs = list(L_1 = 1:3, L_2 = 90:91)), + pip = rep(0.01, length(vids)) + ) + ) + full <- computeCsCorrelation(fe, ss) + # Narrowed past both of L_2's variants: the correlation is still the + # fit's, read off its own variants. + narrowed <- endoapply(fe, utils::head, 50L) + expect_warning( + cc <- computeCsCorrelation(narrowed, ss), + "computeCsCorrelation\\(\\): the stored fit was made with" + ) + expect_equal(cc, full) }) # =========================================================================== @@ -3601,7 +3541,7 @@ test_that("susieResult returns NULL when the trimmed susie fit is empty", { conData <- list( # An empty fit with variants present: topLoci must still be aligned # row-for-row, which the entry did not enforce. - finemappingEntry = fineMappingRow( + finemappingEntry = FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:C:T"), susieFit = list(), topLoci = data.frame( @@ -3672,8 +3612,8 @@ test_that("buildTopLoci rejects variant ids it cannot place", { "buildTopLoci: parseVariantId produced invalid coordinates" ) # ...and well-formed ids parse to their chrom/pos. - ok <- pecotmr:::.btlParseVariants(c("chr1:100:A:G", "chr1:200:C:T")) - expect_equal(ok$chrom, c("1", "1")) + ok <- pecotmr:::.btlParseVariants(c("chr1:100:A:G", "1:200:C:T")) + expect_equal(ok$chrom, c("chr1", "chr1")) expect_equal(ok$pos, c(100L, 200L)) }) @@ -3809,7 +3749,7 @@ test_that("the N column falls back to the fit N and recycles a scalar", { # buildTopLoci per-condition blocks # =========================================================================== -test_that("conditional lfsr passes through when no coverage level matches", { +test_that("conditional lfsr is all-NA when the fit carries no clfsr", { clf <- array(0.1, dim = c(2L, 3L, 1L)) out <- pecotmr:::.btlCondLfsr( list(lfsr = clf), @@ -3994,8 +3934,9 @@ test_that("the fsusie fast path uses a trimmed fit's precomputed coef", { # =========================================================================== test_that("susieInf is skipped as a result when it was only a chain input", { - # Requesting susie alone with addSusieInf still fits an inf model to chain - # from, but keepInf is FALSE so it must not surface as its own method. + # Requesting susie alone with initializeWithSusieInf still fits an inf + # model to chain from, but keepInf is FALSE so it must not surface as + # its own method. chainOnly <- pecotmr:::.fmResolveSusieChain("susie", TRUE) expect_false(chainOnly$keepInf) expect_null(pecotmr:::.fmXFitOne( @@ -4171,20 +4112,6 @@ test_that("a credible set naming an out-of-range effect is skipped", { expect_true(all(is.na(out))) }) -test_that("no credible sets leaves the conditional lfsr untouched", { - clf <- array(0.05, dim = c(2L, 3L, 1L)) - tbl <- list(list(sets = list(cs = list()))) - out <- pecotmr:::.btlCondLfsr( - list(clfsr = clf), - conditionIdx = 1L, - coverageValues = 0.95, - covSorted = 0.95, - csTables = tbl, - nV = 3L - ) - expect_true(all(is.na(out))) -}) - # --------------------------------------------------------------------------- # susieInf chaining and per-token skips: a chained token reuses the shared # susieInf fit, and a token that produces no fit drops out of the block. @@ -4424,7 +4351,7 @@ test_that(".btlCondLfsr yields all-NA when the primary CS is empty", { }) .fmw_pipRow <- function() { - fineMappingRow( + FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:C:T"), susieFit = list(pip = c(0.8, 0.2)), topLoci = data.frame( @@ -4435,16 +4362,6 @@ test_that(".btlCondLfsr yields all-NA when the primary CS is empty", { ) } -test_that("mergeSusieCs returns NULL when no row carries a credible set", { - res <- GwasFineMappingResult( - studyName = "G1", - method = "susie", - entry = list(.fmw_pipRow()) - ) - # The rows have pip but no cs_95 column, so nothing is extracted. - expect_null(mergeSusieCs(res, coverage = 0.95)) -}) - test_that(".extractCsEntryRows needs a resolvable pip column", { topLoci <- data.frame( variant_id = c("v1", "v2"), @@ -4463,7 +4380,7 @@ test_that(".extractCsEntryRows needs a resolvable pip column", { test_that("susieResult returns NULL for an empty susie fit", { expect_null(susieResult(list())) expect_null(susieResult(list(a = 1))) - row <- fineMappingRow( + row <- FineMappingRow( variantIds = "chr1:1:A:G", susieFit = list(), topLoci = data.frame( @@ -4519,7 +4436,7 @@ test_that(".fsusieScaleCols reads the wavelet columns off a flat prior", { test_that("fsusieWeights attaches the fit only when asked", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") - obj <- .fw_makeFsusieFit() + obj <- .fw_fsusieDefault kept <- fsusieWeights( fsusieFit = obj$fit, variantIds = colnames(obj$X), @@ -4727,25 +4644,6 @@ test_that("serWeights extracts weights from a single-effect fit", { expect_error(serWeights(), "no 'ser' fit supplied") }) -test_that("ser is reachable as a TWAS method", { - # It is fit-derived like susie/mvsusie, so it carries no learner - # arguments and its entry is an empty stub. - expect_true(is_in("ser", names(pecotmr:::.twasMethodMap))) - expect_equal(pecotmr:::.twasMethodMap$ser$impl, "serWeights") - expect_length(pecotmr:::.twasMethodMap$ser$args, 0L) - expect_setequal( - pecotmr:::.twasNormalizeMethods(c("ser", "lasso"))$tokens, - c("ser", "lasso") - ) - # Nothing to configure, same as the other fit-derived methods. - expect_error( - TwasWeightsMethodsParam( - qtlSumStatsMethods = list(ser = list(nope = 1)) - ), - "nothing to configure here" - ) -}) - test_that(".fmSerScreen: disables on 0, skips no-signal, keeps signal + adaptive", { skip_if_not_installed("susieR") set.seed(1) @@ -5035,7 +4933,7 @@ test_that(".fmFitSusieIndiv: susieInf branch passes convergence_method='pip', re expect_equal(captured$lastArgs$unmappable_effects, "inf") }) -test_that(".fmFitSusieIndiv: chained branch (chainFromInf) propagates susieInf fit as model_init", { +test_that(".fmFitSusieIndiv: a chained token starts from the susieInf fit", { captured <- new.env(parent = emptyenv()) X <- matrix(rnorm(20), 10, 2) y <- rnorm(10) @@ -5045,25 +4943,18 @@ test_that(".fmFitSusieIndiv: chained branch (chainFromInf) propagates susieInf f susie = .fmp_capturingSusie(captured), .package = "susieR" ) - pecotmr:::.fmFitSusieIndiv(X, y, "susie", chainFromInf = infFit) - # prepareSusieFromInfArgs writes the susieInf fit into model_init and - # sets unmappable_effects to "none" for the `susie` token. - expect_identical(captured$lastArgs$model_init, infFit) - expect_equal(captured$lastArgs$unmappable_effects, "none") -}) - -test_that(".fmFitSusieIndiv: chained susieAsh branch sets unmappable_effects='ash'", { - captured <- new.env(parent = emptyenv()) - X <- matrix(rnorm(20), 10, 2) - y <- rnorm(10) - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie = .fmp_capturingSusie(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieIndiv(X, y, "susieAsh", chainFromInf = infFit) - expect_equal(captured$lastArgs$unmappable_effects, "ash") - expect_identical(captured$lastArgs$model_init, infFit) + # prepareSusieFromInfArgs writes the susieInf fit into model_init and sets + # each token's unmappable_effects. + unmappable <- c(susie = "none", susieAsh = "ash") + for (token in names(unmappable)) { + pecotmr:::.fmFitSusieIndiv(X, y, token, chainFromInf = infFit) + expect_identical(captured$lastArgs$model_init, infFit, info = token) + expect_equal( + captured$lastArgs$unmappable_effects, + unmappable[[token]], + info = token + ) + } }) test_that(".fmFitSusieIndiv: unchained susieAsh branch sets convergence_method='pip'", { @@ -5106,7 +4997,7 @@ test_that(".fmFitSusieRss: susieInf branch passes convergence_method='pip', refi expect_equal(captured$lastArgs$unmappable_effects, "inf") }) -test_that(".fmFitSusieRss: chained branch (chainFromInf) propagates susieInf fit as model_init", { +test_that(".fmFitSusieRss: a chained token starts from the susieInf fit", { captured <- new.env(parent = emptyenv()) z <- rnorm(3) R <- diag(3) @@ -5116,24 +5007,16 @@ test_that(".fmFitSusieRss: chained branch (chainFromInf) propagates susieInf fit susie_rss = .fmp_capturingSusieRss(captured), .package = "susieR" ) - pecotmr:::.fmFitSusieRss(z, R, n, "susie", chainFromInf = infFit) - expect_identical(captured$lastArgs$model_init, infFit) - expect_equal(captured$lastArgs$unmappable_effects, "none") -}) - -test_that(".fmFitSusieRss: chained susieAsh branch sets unmappable_effects='ash'", { - captured <- new.env(parent = emptyenv()) - z <- rnorm(3) - R <- diag(3) - n <- 1000 - infFit <- list(V = c(0.1, 0.2)) - local_mocked_bindings( - susie_rss = .fmp_capturingSusieRss(captured), - .package = "susieR" - ) - pecotmr:::.fmFitSusieRss(z, R, n, "susieAsh", chainFromInf = infFit) - expect_equal(captured$lastArgs$unmappable_effects, "ash") - expect_identical(captured$lastArgs$model_init, infFit) + unmappable <- c(susie = "none", susieAsh = "ash") + for (token in names(unmappable)) { + pecotmr:::.fmFitSusieRss(z, R, n, token, chainFromInf = infFit) + expect_identical(captured$lastArgs$model_init, infFit, info = token) + expect_equal( + captured$lastArgs$unmappable_effects, + unmappable[[token]], + info = token + ) + } }) test_that(".fmFitSusieRss: unchained susieAsh branch sets convergence_method='pip'", { @@ -5172,39 +5055,14 @@ test_that(".buildMvsusieReweightedPrior: empty reweighted w0 -> canonical(V)", { V = diag(2) ) res <- pecotmr:::.buildMvsusieReweightedPrior(fp, c("c1", "c2")) - expect_equal(res$residualVariance, diag(2)) # w0 names disjoint from U (749) -}) - -test_that(".fmSerScreen / .fmScreenActive / .fmSerScreenColumns", { - set.seed(2) - X <- matrix( - rnorm(40), - 20, - 2, - dimnames = list(paste0("s", 1:20), c("chr1:100:A:G", "chr1:200:A:G")) - ) - y <- rnorm(20) - expect_true(pecotmr:::.fmSerScreen(X, y, 0)) # disabled - expect_true(pecotmr:::.fmSerScreen(X, c(1, rep(NA, 19)), 0.5)) # < 2 obs (880) - expect_type(pecotmr:::.fmSerScreen(X, y, 0.5), "logical") # real susie fit - local_mocked_bindings( - susie = function(...) stop("boom"), - .package = "susieR" - ) - expect_true(pecotmr:::.fmSerScreen(X, y, 0.5)) # fit fails -> keep (886) - expect_false(pecotmr:::.fmScreenActive(0)) - expect_true(pecotmr:::.fmScreenActive(0.5)) - expect_length( - pecotmr:::.fmSerScreenColumns(X, matrix(rnorm(40), 20, 2), 0), - 2L - ) + expect_equal(res$residualVariance, diag(2)) # w0 names disjoint from U }) test_that(".fmFitXBlock fits the susieInf indiv chain + cross-validates (mocked)", { local_mocked_bindings( .fmFitSusieIndiv = function(...) list(), .fmPostprocessOne = function(fit, method, dataX, dataY, ...) { - fineMappingRow( + FineMappingRow( colnames(dataX), list(), data.frame(variant_id = colnames(dataX), pip = 0.5) @@ -5420,10 +5278,6 @@ test_that("krigingOutlierQc forwards methodArgs to susieR::kriging_rss", { ) }) -# Fixtures moved here with the tests that use them. - -# Fixtures moved here with the tests that use them. - # --------------------------------------------------------------------------- # buildTopLoci: the PIP filter and the z-only source # --------------------------------------------------------------------------- @@ -5552,13 +5406,6 @@ test_that("mu and mu2 of different shapes yield no conditional lfsr", { ))) }) -test_that("an empty window parses to no coordinates", { - expect_equal( - .parseGrange(GenomicRanges::GRanges()), - c(start = NA_integer_, end = NA_integer_) - ) -}) - test_that("merging two already-merged blocks changes nothing", { parent <- list(a = "a", b = "b") once <- .ufUnion("a", "b", parent) @@ -5633,3 +5480,32 @@ test_that("a screen whose marginal z cannot be computed falls back", { # colocboost passes FALSE: it drops an outcome it cannot screen. expect_false(.fmSerScreen(X, y, scr, fallback = FALSE)) }) + +test_that("computeCsCorrelation refuses an ldSource on several references", { + # Nothing in the fit says which of the rows' references it was computed + # against, so a source with several is refused rather than guessed at. + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + panel <- ldReference(mc)[[1L]] + ids <- c("chr1:100:A:G", "chr1:200:C:T") + refs <- rep(list(panel), nrow(mc)) + refs[[2L]] <- LdMatrix(`dimnames<-`(diag(2), list(ids, ids))) + two <- pecotmr:::.withRowLdRefs(mc, refs) + vids <- rownames(panel) + fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(4L, 5L))) + expect_error( + computeCsCorrelation(fe, two), + "rows use 2 different LD references" + ) +}) + +test_that("computeCsCorrelation refuses an LD-free summary-statistics source", { + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + vids <- rownames(ldReference(mc)[[1L]]) + fe <- .ccMakeEntry(vids, list(L1 = c(1L, 2L, 3L), L2 = c(4L, 5L))) + expect_error( + computeCsCorrelation(fe, pecotmr:::.withRowLdRefs(mc, NULL)), + "carries no LD reference" + ) +}) diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index de075fdf..4988381f 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -41,17 +41,20 @@ test_that("GenotypeHandle: partial pgen/pvar/psam triplet errors", { ) }) -test_that("GenotypeHandle: ldMeta without region errors", { +test_that("GenotypeHandle: ldMeta without which errors", { expect_error( GenotypeHandle(ldMeta = "x.tsv"), - "`ldMeta` requires a `region`" + "`ldMeta` requires `block`" ) }) -test_that("GenotypeHandle: region without ldMeta errors", { +test_that("GenotypeHandle: which without ldMeta errors", { expect_error( - GenotypeHandle(path = gds_path, region = "chr1:1-100"), - "`region` is only meaningful when `ldMeta`" + GenotypeHandle( + path = gds_path, + block = GenomicRanges::GRanges("chr1:1-100") + ), + "`block` is only meaningful when `ldMeta`" ) }) @@ -133,26 +136,16 @@ test_that("GenotypeHandle: pgen/pvar/psam triplet with matching stems builds pli test_that(".genotypeHandleFromPlink2Triplet: accepts .pvar.zst by stripping the .zst", { skip_if_not_installed("pgenlibr") - # We only check that the stem-validation accepts the zst-suffixed pvar; - # the actual file does not exist, so the downstream reader will error. + # The stems agree once the .zst is stripped, so the call gets past the + # stem check and fails only in the reader, on the files not existing. expect_error( pecotmr:::.genotypeHandleFromPlink2Triplet( pgen = "/tmp/x.pgen", pvar = "/tmp/x.pvar.zst", psam = "/tmp/x.psam" ), - NA # stems agree, so the stem-check should not fire - ) |> - suppressWarnings() |> - tryCatch(error = function(e) { - # The downstream reader will fail because /tmp/x.pgen doesn't exist — - # but the failure mode is what we want to confirm is *not* the stem - # mismatch error. - expect_false(grepl( - "must share a common path stem", - conditionMessage(e) - )) - }) + "PLINK2 .pgen file.*File does not exist" + ) }) test_that(".genotypeHandleFromPlink2Triplet: errors when stems disagree", { @@ -181,38 +174,13 @@ test_that(".genotypeHandleFromPlink2Triplet: errors on non-character input", { # .genotypeHandleFromLdMeta: dispatch by file extension # =========================================================================== -.gh_makeLdMetaForGds <- function() { - meta <- data.frame( - chrom = "chr21", - start = 17000000L, - end = 18000000L, - path = gds_path, - stringsAsFactors = FALSE - ) - f <- tempfile(fileext = ".tsv") - write.table(meta, f, sep = "\t", quote = FALSE, row.names = FALSE) - f -} - -.gh_makeLdMetaForVcf <- function() { - meta <- data.frame( - chrom = "chr21", - start = 17000000L, - end = 18000000L, - path = vcf_path, - stringsAsFactors = FALSE - ) - f <- tempfile(fileext = ".tsv") - write.table(meta, f, sep = "\t", quote = FALSE, row.names = FALSE) - f -} - -.gh_makeLdMetaForBed <- function() { +# An LD-meta file whose one row names `path` for chr21:17000000-18000000. +.gh_makeLdMeta <- function(path) { meta <- data.frame( chrom = "chr21", start = 17000000L, end = 18000000L, - path = paste0(plink_prefix, ".bed"), + path = path, stringsAsFactors = FALSE ) f <- tempfile(fileext = ".tsv") @@ -220,66 +188,34 @@ test_that(".genotypeHandleFromPlink2Triplet: errors on non-character input", { f } -.gh_makeLdMetaForPgen <- function() { - meta <- data.frame( - chrom = "chr21", - start = 17000000L, - end = 18000000L, - path = paste0(plink_prefix, ".pgen"), - stringsAsFactors = FALSE - ) - f <- tempfile(fileext = ".tsv") - write.table(meta, f, sep = "\t", quote = FALSE, row.names = FALSE) - f -} - -.gh_makeLdMetaForCor <- function() { - # findValidFilePath needs the target file to exist (otherwise it falls - # back to returning the meta-TSV path itself, which would dead-end the - # downstream format dispatch elsewhere). Materialize an empty .cor.xz so - # we exercise the proper "cor.xz payload" rejection branch. - corPath <- tempfile(fileext = ".cor.xz") - file.create(corPath) - meta <- data.frame( - chrom = "chr21", - start = 17000000L, - end = 18000000L, - path = corPath, - stringsAsFactors = FALSE - ) - f <- tempfile(fileext = ".tsv") - write.table(meta, f, sep = "\t", quote = FALSE, row.names = FALSE) - list(meta = f, cor = corPath) -} - -test_that("an LD-meta row naming a .gds file is read as a panel", { +test_that("an LD-meta row naming a GDS, VCF or PLINK1 file reads as a panel", { skip_if_not_installed("gdsfmt") skip_if_not_installed("GDSArray") - f <- .gh_makeLdMetaForGds() - on.exit(unlink(f), add = TRUE) - 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("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) - 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") + skip_if_not_installed("PlinkMatrix") + region <- GenomicRanges::GRanges("chr21:17513228-17592874") + files <- c( + gds = gds_path, + vcf = vcf_path, + plink1 = paste0(plink_prefix, ".bed") + ) + for (format in names(files)) { + f <- .gh_makeLdMeta(files[[format]]) + on.exit(unlink(f), add = TRUE) + expect_error( + GenotypeHandle(ldMeta = f, block = region), + "read as a genotype panel", + info = format + ) + panel <- readGenotypes(ldMeta = f, block = region) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(349L, 100L), info = format) + expect_equal( + S4Vectors::metadata(panel)$genotypeSource$format, + format, + info = format + ) + } }) test_that("an LD-meta row's file is read by the reader its format names", { @@ -296,67 +232,62 @@ test_that("an LD-meta row's file is read by the reader its format names", { ) }) -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) - 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", { skip_if_not_installed("pgenlibr") - f <- .gh_makeLdMetaForPgen() + f <- .gh_makeLdMeta(paste0(plink_prefix, ".pgen")) on.exit(unlink(f), add = TRUE) - h <- GenotypeHandle(ldMeta = f, region = "chr21:17513228-17592874") + h <- GenotypeHandle( + ldMeta = f, + block = GenomicRanges::GRanges("chr21:17513228-17592874") + ) expect_s4_class(h, "GenotypeHandle") expect_equal(genotypeFormat(h), "plink2") }) test_that("GenotypeHandle ldMeta: .cor.xz payload is rejected (out of scope)", { - paths <- .gh_makeLdMetaForCor() - on.exit(unlink(c(paths$meta, paths$cor)), add = TRUE) + # findValidFilePath needs the target file to exist (otherwise it falls + # back to returning the meta-TSV path itself, which would dead-end the + # downstream format dispatch elsewhere). Materialize an empty .cor.xz so + # we exercise the proper "cor.xz payload" rejection branch. + corPath <- tempfile(fileext = ".cor.xz") + file.create(corPath) + meta <- .gh_makeLdMeta(corPath) + on.exit(unlink(c(meta, corPath)), add = TRUE) expect_error( - GenotypeHandle(ldMeta = paths$meta, region = "chr21:17513228-17592874"), + GenotypeHandle( + ldMeta = meta, + block = GenomicRanges::GRanges("chr21:17513228-17592874") + ), "points at a pre-computed correlation matrix" ) }) test_that("GenotypeHandle ldMeta: region with no covering row errors", { - f <- .gh_makeLdMetaForGds() + f <- .gh_makeLdMeta(gds_path) on.exit(unlink(f), add = TRUE) # The upstream helper emits "No data for chromosome ..." when nothing on # the region's chromosome exists in the meta TSV; either phrasing # indicates the same "region uncovered" failure mode. expect_error( - GenotypeHandle(ldMeta = f, region = "chr22:1-1000"), + GenotypeHandle( + ldMeta = f, + block = GenomicRanges::GRanges("chr22:1-1000") + ), "No data for chromosome|no LD-meta row covers" ) }) -# === Tests migrated from test_h2ClassesSumstats.R (GenotypeHandle) === - -test_that("GenotypeHandle constructs and validates correctly", { - obj <- new( - "GenotypeHandle", - path = "/tmp/test", - format = "plink2", - snpInfo = makeTestSnpInfo(), - nSamples = 100L, - sampleIds = paste0("sample_", 1:100), - pgenPtr = NULL +test_that("GenotypeHandle ldMeta: the window to look up is a GRanges", { + f <- .gh_makeLdMeta(gds_path) + on.exit(unlink(f), add = TRUE) + expect_error( + GenotypeHandle(ldMeta = f, block = "chr21:17513228-17592874"), + "`block` must be a GRanges" ) - expect_s4_class(obj, "GenotypeHandle") - expect_equal(genotypeFormat(obj), "plink2") - expect_true(methods::validObject(obj)) + expect_error(GenotypeHandle(ldMeta = f), "requires `block`") }) +# === Tests migrated from test_h2ClassesSumstats.R (GenotypeHandle) === test_that("GenotypeHandle refuses the formats it no longer reads", { for (fmt in c("vcf", "gds", "plink1")) { @@ -375,7 +306,7 @@ test_that("GenotypeHandle refuses the formats it no longer reads", { } }) -test_that("GenotypeHandle accepts all valid formats", { +test_that("GenotypeHandle constructs and validates every format it reads", { for (fmt in c("plink2", "bgen")) { obj <- new( "GenotypeHandle", @@ -386,47 +317,18 @@ test_that("GenotypeHandle accepts all valid formats", { sampleIds = character(), pgenPtr = NULL ) + expect_s4_class(obj, "GenotypeHandle") + expect_equal(genotypeFormat(obj), fmt) expect_true(methods::validObject(obj)) } }) - -test_that("GenotypeHandle rejects invalid format", { - expect_error( - methods::validObject( - new( - "GenotypeHandle", - path = "/tmp/test", - format = "zarr", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) - ), - "format.*must be one of" - ) -}) - # =========================================================================== # One-file-per-chromosome (sharded) handle: constructor + validation. # genoMeta accepts a #chr,path meta file or a named chrom->path vector. -# Extraction routing for sharded handles is covered in test_genotypeIo.R. +# The named-vector handle is built and checked with its extraction routing +# in test_genotypeIo.R. # =========================================================================== -test_that("genoMeta (named vector) builds a sharded handle", { - skip_if_not_installed("pgenlibr") - h <- GenotypeHandle( - genoMeta = c( - "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), "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("pgenlibr") # A meta file living in test_data referencing payloads by basename only. @@ -441,7 +343,7 @@ test_that("genoMeta meta-file resolves payloads relative to its own directory", metafile ) h <- GenotypeHandle(genoMeta = metafile) - expect_equal(sort(names(chromPaths(h))), c("21", "22")) + expect_equal(sort(names(chromPaths(h))), c("chr21", "chr22")) expect_equal(nrow(snpInfo(h)), 2L * 349L) }) @@ -459,13 +361,13 @@ test_that(".parseChromMeta matches chrom/path columns by name (order- and extra- "22\t1\t9\t/abs/b.bed" )) ) - expect_equal(m1$chrom, c("21", "22")) + expect_equal(m1$chrom, c("chr21", "chr22")) expect_equal(m1$path, c("/abs/a.bed", "/abs/b.bed")) # reordered header (path first) + alias column names m2 <- pecotmr:::.parseChromMeta( mk(c("genotype\tchr", "/abs/a.bed\t21", "/abs/b.bed\t22")) ) - expect_equal(m2$chrom, c("21", "22")) + expect_equal(m2$chrom, c("chr21", "chr22")) expect_equal(m2$path, c("/abs/a.bed", "/abs/b.bed")) }) @@ -478,7 +380,7 @@ test_that(".parseChromMeta falls back to the first two columns when no alias hea m <- pecotmr:::.parseChromMeta( mk(c("foo\tbar", "21\t/abs/a.bed", "22\t/abs/b.bed")) ) - expect_equal(m$chrom, c("21", "22")) + expect_equal(m$chrom, c("chr21", "chr22")) expect_equal(m$path, c("/abs/a.bed", "/abs/b.bed")) }) @@ -595,16 +497,16 @@ test_that("genoMeta chroms reads only the requested shard", { ) full <- GenotypeHandle(genoMeta = meta) only21 <- GenotypeHandle(genoMeta = meta, chroms = "21") - expect_equal(names(chromPaths(only21)), "21") + expect_equal(names(chromPaths(only21)), "chr21") expect_equal(nrow(snpInfo(only21)), 349L) # chr21 is the first shard, so the kept rows/fileIdx match the full handle's. expect_equal(snpInfo(only21)$SNP, snpInfo(full)$SNP[1:349]) expect_equal(snpInfo(only21)$fileIdx, snpInfo(full)$fileIdx[1:349]) }) -test_that("genoMeta chroms canonicalises chromosome labels", { +test_that("genoMeta chroms reads chromosome labels in any style", { skip_if_not_installed("pgenlibr") - # "chr21" canonicalises to the panel's declared "21" shard. + # "chr21" names the shard the panel declares as "21". h <- GenotypeHandle( genoMeta = c( "21" = file.path(test_data_dir, "test_variants.pgen"), @@ -612,7 +514,7 @@ test_that("genoMeta chroms canonicalises chromosome labels", { ), chroms = "chr21" ) - expect_equal(names(chromPaths(h)), "21") + expect_equal(names(chromPaths(h)), "chr21") }) test_that("genoMeta chroms falls back to all shards when none match", { @@ -626,7 +528,7 @@ test_that("genoMeta chroms falls back to all shards when none match", { ), chroms = "9" ) - expect_equal(sort(names(chromPaths(h))), c("21", "22")) + expect_equal(sort(names(chromPaths(h))), c("chr21", "chr22")) }) test_that("genoMeta chroms skips a shard whose file does not exist", { @@ -638,7 +540,7 @@ test_that("genoMeta chroms skips a shard whose file does not exist", { "21" = "/no/such/chr21/prefix" ) h <- GenotypeHandle(genoMeta = meta, chroms = "22") - expect_equal(names(chromPaths(h)), "22") + expect_equal(names(chromPaths(h)), "chr22") expect_error(GenotypeHandle(genoMeta = meta, chroms = c("22", "21"))) }) @@ -840,21 +742,6 @@ test_that("show(GenotypeHandle) does not error", { # 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", { - # 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) - expect_equal(ncol(se), nSamples(gh)) -}) - 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 @@ -922,17 +809,6 @@ test_that(".emptyGenotypeHandle empties the sample axis as well as the variants" expect_equal(lengths(dimnames(seed)), c(0L, 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. gh <- .gh_pgenHandle() diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index 808b0e09..af15fef1 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -10,195 +10,6 @@ test_that("readPvar reads real pvar file", { expect_true(all(res$chrom == "21")) }) -test_that("readBim dummy data works", { - example_path <- "test_data/protocol_example.genotype.bed" - res <- readBim(example_path) - expect_equal(colnames(res), c("chrom", "id", "gpos", "pos", "a1", "a0")) - expect_equal(nrow(res), 100) -}) - -test_that("findValidFilePath works", { - ref_path <- "test_data/protocol_example.genotype.bed" - expect_error( - pecotmr:::.findValidFilePath( - referenceFilePath = paste0(ref_path, "s"), - targetFilePath = "protocol_example.genotype.bamf" - ), - "Both reference and target file paths do not work. Tried paths: 'test_data/protocol_example.genotype.beds' and 'test_data/protocol_example.genotype.bamf'" - ) - expect_equal( - pecotmr:::.findValidFilePath( - referenceFilePath = ref_path, - targetFilePath = "abc" - ), - ref_path - ) - expect_equal( - pecotmr:::.findValidFilePath( - referenceFilePath = ref_path, - targetFilePath = "protocol_example.genotype.bim" - ), - "test_data/protocol_example.genotype.bim" - ) - expect_equal( - pecotmr:::.findValidFilePath( - referenceFilePath = ref_path, - targetFilePath = "test_data/protocol_example.genotype.bim" - ), - "test_data/protocol_example.genotype.bim" - ) -}) - -dummyGenoData <- function( - number_of_samples = 10, - number_of_snps = 10, - sample_start_id = 1, - number_missing = 10, - number_low_maf = 10, - number_zero_var = 10, - number_var_thresh = 10 -) { - set.seed(1) - # Create portion of Matrix with satisfactory values - X <- matrix( - sample(c(0, 1, 2), number_of_samples * number_of_snps, replace = TRUE), - nrow = number_of_samples, - ncol = number_of_snps - ) - # Create portion of Matrix that should get pruned - ## Missing Rate - if (number_missing > 0) { - X_missing <- rbind( - matrix( - sample( - c(0, 1, 2), - (number_of_samples - 3) * number_of_snps, - replace = TRUE - ), - nrow = number_of_samples - 3, - ncol = number_of_snps - ), - matrix( - rep(NA, 3 * number_of_snps), - nrow = 3, - ncol = number_of_snps - ) - ) - X <- cbind(X, X_missing) - } - ## MAF - if (number_low_maf > 0) { - X_maf <- matrix( - rep(0.1, number_of_samples * number_of_snps), - nrow = number_of_samples, - ncol = number_of_snps - ) - X <- cbind(X, X_maf) - } - ## Zero Variance - if (number_zero_var > 0) { - X_zerovar <- matrix( - rep(1, number_of_samples * number_of_snps), - nrow = number_of_samples, - ncol = number_of_snps - ) - X <- cbind(X, X_zerovar) - } - ## Variance Threshold, just one row - if (number_var_thresh > 0) { - X_varthresh <- matrix( - c(rep(1, (number_of_samples - 1)), 2), - nrow = number_of_samples, - ncol = 1 - ) - X <- cbind(X, X_varthresh) - } - colnames(X) <- paste0( - "chr1:", - seq( - 1000, - 1000 + - number_of_snps + - number_missing + - number_low_maf + - number_zero_var + - number_var_thresh - - 1 - ), - "_G_C" - ) - rownames(X) <- paste0( - "Sample_", - seq(sample_start_id, number_of_samples + sample_start_id - 1) - ) - return(X) -} - -dummyPhenoData <- function( - number_of_samples = 10, - number_of_phenotypes = 10, - randomize = FALSE, - sample_start_id = 1 -) { - # Create dummy phenotype bed file - # columns: Chrom, Start, End, Sample_1, Sample_2, ..., Sample_N - start_matrix <- matrix( - c( - rep("chr1", number_of_phenotypes), - seq(100, 100 + number_of_phenotypes - 1), - seq(101, 101 + number_of_phenotypes - 1) - ), - nrow = number_of_phenotypes, - ncol = 3 - ) - end_matrix <- matrix( - rnorm(number_of_samples * number_of_phenotypes), - nrow = number_of_phenotypes, - ncol = number_of_samples - ) - pheno_data <- cbind(start_matrix, end_matrix) - sample_ids <- paste0( - "Sample_", - seq(sample_start_id, number_of_samples + sample_start_id - 1) - ) - colnames(pheno_data) <- c("#chr", "start", "end", sample_ids) - colnames(end_matrix) <- sample_ids - if (randomize) { - end_matrix <- end_matrix[sample(nrow(end_matrix)), ] - } - pheno_data <- t(pheno_data) - pheno_data <- map(seq_len(ncol(pheno_data)), function(i) { - pheno_data[, i, drop = FALSE] - }) - return(pheno_data) -} - -dummyCovarData <- function( - number_of_samples = 10, - number_of_covars = 10, - row_na = FALSE, - randomize = FALSE, - sample_start_id = 1 -) { - covar <- matrix( - sample(1:20, number_of_samples * number_of_covars, replace = TRUE), - nrow = number_of_samples, - ncol = number_of_covars - ) - colnames(covar) <- paste0("Covar_", seq(1, number_of_covars)) - rownames(covar) <- paste0( - "Sample_", - seq(sample_start_id, number_of_samples + sample_start_id - 1) - ) - if (randomize) { - covar <- covar[sample(nrow(covar)), ] - } - if (row_na) { - covar[sample(length(covar), 1), seq_len(number_of_covars)] <- NA - } - return(covar) -} - test_that("Test loadGenotypeRegion", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype" @@ -247,7 +58,7 @@ test_that("Test loadGenotypeRegion no indels", { test_that("Test loadGenotypeRegion with region", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype", - region = "chr22:20689453-20845958" + which = GenomicRanges::GRanges("chr22:20689453-20845958") ) sample_ids <- read_delim( "test_data/protocol_example.genotype.fam", @@ -270,7 +81,7 @@ test_that("Test loadGenotypeRegion with region", { test_that("Test loadGenotypeRegion with region and no indels", { res <- loadGenotypeRegion( "test_data/protocol_example.genotype", - region = "chr22:20689453-20845958", + which = GenomicRanges::GRanges("chr22:20689453-20845958"), keepIndel = F ) bim_file <- read_delim( @@ -300,53 +111,24 @@ test_that("Test loadGenotypeRegion with region and no indels", { expect_equal(colnames(res), bim_file[!indels, ]$X2) }) -test_that("loadGenotypeRegion errors on missing genotype files", { - expect_error( - loadGenotypeRegion("/nonexistent/geno"), - "neither a genotype file nor a PLINK prefix" - ) -}) - # --- findStochasticMeta tests --- -test_that("findStochasticMeta finds generic sidecar from PLINK1 prefix", { - td <- test_path("test_data") - # test_harmonize_regions has .stochastic_meta.tsv alongside it - result <- pecotmr:::findStochasticMeta(file.path( - td, - "test_harmonize_regions" - )) - expect_true(!is.null(result)) - expect_true(grepl("\\.(afreq|stochastic_meta\\.tsv)$", result)) -}) - -test_that("findStochasticMeta finds sidecar from VCF path", { - td <- test_path("test_data") - result <- pecotmr:::findStochasticMeta(file.path( - td, - "test_harmonize_regions.vcf.gz" - )) - expect_true(!is.null(result)) - expect_true(grepl("\\.(afreq|stochastic_meta\\.tsv)$", result)) -}) - -test_that("findStochasticMeta finds sidecar from GDS path", { - td <- test_path("test_data") - result <- pecotmr:::findStochasticMeta(file.path( - td, - "test_harmonize_regions.gds" - )) - expect_true(!is.null(result)) - expect_true(grepl("\\.(afreq|stochastic_meta\\.tsv)$", result)) -}) - -test_that("findStochasticMeta finds the sidecar of a BGEN or .vcf.bgz file", { +test_that("findStochasticMeta finds the sidecar beside a file or prefix", { dir <- withr::local_tempdir() file.create(file.path(dir, "sketch.afreq")) - for (file in c("sketch.bgen", "sketch.vcf.bgz", "sketch.VCF.GZ")) { + files <- c( + "sketch", + "sketch.bgen", + "sketch.gds", + "sketch.vcf.gz", + "sketch.vcf.bgz", + "sketch.VCF.GZ" + ) + for (file in files) { expect_equal( pecotmr:::findStochasticMeta(file.path(dir, file)), - file.path(dir, "sketch.afreq") + file.path(dir, "sketch.afreq"), + info = file ) } }) @@ -381,6 +163,13 @@ test_that("readStochasticMeta reads afreq format", { expect_equal(colnames(result), c("id", "u_min", "u_max")) expect_equal(nrow(result), 8L) expect_true(all(grepl("^chr21_", result$id))) + # The generic sidecar beside it holds the same values. + generic <- pecotmr:::readStochasticMeta( + file.path(td, "test_harmonize_regions.stochastic_meta.tsv") + ) + expect_equal(result$id, generic$id) + expect_equal(result$u_min, generic$u_min) + expect_equal(result$u_max, generic$u_max) }) test_that("readStochasticMeta reads afreq.zst format", { @@ -408,30 +197,37 @@ test_that("findStochasticMeta prefers afreq over afreq.zst", { expect_true(grepl("\\.afreq$", result)) }) -test_that("readStochasticMeta auto-detects format from extension", { - td <- test_path("test_data") - # .afreq extension -> afreq parser - afreq_result <- pecotmr:::readStochasticMeta(file.path( - td, - "test_harmonize_regions.afreq" - )) - # .tsv extension -> generic parser - generic_result <- pecotmr:::readStochasticMeta( - file.path(td, "test_harmonize_regions.stochastic_meta.tsv") +test_that("readStochasticMeta reads a forced afreq file under any name", { + # The override reads the file it is given; it once appended .afreq to + # the name and read .afreq instead, so nothing came back. + src <- test_path("test_data", "test_harmonize_regions.afreq") + renamed <- file.path(withr::local_tempdir(), "sidecar.txt") + file.copy(src, renamed) + expect_equal( + pecotmr:::readStochasticMeta(renamed, format = "afreq"), + pecotmr:::readStochasticMeta(src) + ) + expect_named( + pecotmr:::readStochasticMeta(renamed, format = "afreq"), + c("id", "u_min", "u_max") ) - # Both should return the same u_min/u_max values - expect_equal(afreq_result$u_min, generic_result$u_min) - expect_equal(afreq_result$u_max, generic_result$u_max) - expect_equal(afreq_result$id, generic_result$id) }) test_that("readStochasticMeta respects format override", { - td <- test_path("test_data") - path <- file.path(td, "test_harmonize_regions.stochastic_meta.tsv") - # Explicit generic format should work - result <- pecotmr:::readStochasticMeta(path, format = "generic") - expect_equal(nrow(result), 8L) - expect_equal(colnames(result), c("id", "u_min", "u_max")) + # A generic id/u_min/u_max table saved under an .afreq name: left to its + # extension it goes to the PLINK2 .afreq reader, which cannot parse it. + generic <- test_path( + "test_data", + "test_harmonize_regions.stochastic_meta.tsv" + ) + path <- file.path(withr::local_tempdir(), "sidecar.afreq") + file.copy(generic, path) + expect_error(pecotmr:::readStochasticMeta(path), "#CHROM") + # Forcing "generic" reads it as the table it is. + expect_equal( + pecotmr:::readStochasticMeta(path, format = "generic"), + pecotmr:::readStochasticMeta(generic) + ) }) test_that("readStochasticMeta returns NULL for afreq without U_MIN/U_MAX", { @@ -473,7 +269,7 @@ test_that("loadGenotypeRegion applies stochastic inversion with explicit sidecar # Check the first variant's first sample manually raw <- loadGenotypeRegion( file.path(td, "protocol_example.genotype"), - region = "chr22:20689453-20845958" + which = GenomicRanges::GRanges("chr22:20689453-20845958") ) # protocol_example has no sidecar, so raw values are unchanged (integer dosages) expect_true(all(raw == round(raw), na.rm = TRUE)) @@ -506,40 +302,6 @@ test_that("readBim returns correct columns and types", { # .colocFilterCsByConcentration # =========================================================================== -test_that(".colocFilterCsByConcentration returns numeric index vector", { - set.seed(42) - n_L <- 5 - n_vars <- 20 - alpha_raw <- matrix(runif(n_L * n_vars), nrow = n_L) - alpha_norm <- t(apply(alpha_raw, 1, function(x) x / sum(x))) - - mockSusie <- list( - alpha = alpha_norm, - V = runif(n_L), - lbf_variable = matrix(rnorm(n_L * n_vars), nrow = n_L), - mu = matrix(rnorm(n_L * n_vars), nrow = n_L), - mu2 = matrix(abs(rnorm(n_L * n_vars)), nrow = n_L), - sets = list( - cs = list(L1 = c(1, 3, 5), L3 = c(2, 4)), - cs_index = c(1, 3) - ), - pip = colSums(alpha_norm), - niter = 100, - converged = TRUE - ) - - result <- pecotmr:::.colocFilterCsByConcentration( - mockSusie, - coverage = 0.5, - concentration = 0.5 - ) - expect_true(is.numeric(result)) -}) - -# =========================================================================== -# refVariantInfo -# =========================================================================== - # ---- invertMinmaxScaling ---- test_that("invertMinmaxScaling exactly recovers original U", { @@ -565,32 +327,15 @@ test_that("invertMinmaxScaling exactly recovers original U", { expect_equal(U_recovered, U_original, tolerance = 1e-12) }) -test_that("invertMinmaxScaling preserves correlation structure", { - set.seed(123) - n <- 200 - k <- 3 - # Simulate U = W'G (G is raw, not standardized, matching rss_ld_sketch) - G <- exec(cbind, !!!map(c(0.2, 0.4, 0.1), function(p) rbinom(n, 2, p))) - W <- matrix(rnorm(n * n, 0, 1 / sqrt(n)), n, n) - U_original <- crossprod(W, G) - - # Scale and invert - u_min <- apply(U_original, 2, min) - u_max <- apply(U_original, 2, max) - denom <- u_max - u_min - U_scaled <- sweep(sweep(U_original, 2, u_min, "-"), 2, denom, "/") * 2 - U_recovered <- invertMinmaxScaling(U_scaled, u_min, u_max) - - # Exact recovery - expect_equal(U_recovered, U_original, tolerance = 1e-12) -}) - test_that("invertMinmaxScaling handles monomorphic variant", { - X <- matrix(c(1.0, 1.0, 1.0, 0.5, 1.0, 1.5), ncol = 2) - u_min <- c(0.5, 0.0) - u_max <- c(0.5, 1.0) # first column is monomorphic - result <- invertMinmaxScaling(X, u_min, u_max) - expect_equal(ncol(result), 2) + # Column 1 is monomorphic (u_min == u_max). The sketch writer divides it + # by 1 instead of 0, which leaves it all 0, and inverting has to give its + # constant back rather than NaN. + U <- cbind(rep(0.5, 3), c(-1, 0, 3)) + u_min <- c(0.5, -1) + u_max <- c(0.5, 3) + X <- cbind(rep(0, 3), c(0, 0.5, 2)) # 2 * (U - u_min) / c(1, 4) + expect_equal(invertMinmaxScaling(X, u_min, u_max), U) }) test_that("invertMinmaxScaling errors on mismatched lengths", { @@ -602,12 +347,26 @@ test_that("invertMinmaxScaling errors on mismatched lengths", { }) # =========================================================================== -# refVariantInfo with PLINK2 fixture +# refVariantInfo # =========================================================================== +# refVariantInfo() through an LD-metadata file naming `source` for all of +# chr21, written into test_data so its relative path resolves, and removed +# once read. +.gioRefInfoViaMeta <- function(source, which) { + meta <- withr::local_tempfile( + tmpdir = test_path("test_data"), + fileext = ".tsv" + ) + writeLines(c("chrom\tstart\tend\tpath", str_c("21\t0\t0\t", source)), meta) + refVariantInfo(meta, which = which) +} + 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. + skip_if_not_installed("gdsfmt") + skip_if_not_installed("GDSArray") stem <- str_remove( system.file("extdata", "toy_ref.bed", package = "pecotmr"), "\\.bed$" @@ -616,155 +375,45 @@ test_that("refVariantInfo reads a genotype file or prefix given directly", { 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) + gds <- refVariantInfo(test_path("test_data", "test_variants.gds")) + expect_equal(nrow(gds), 349L) }) -test_that("refVariantInfo returns variant info for PLINK2 source", { +test_that("refVariantInfo reads PLINK2, VCF and GDS sources via LD metadata", { skip_if_not_installed("pgenlibr") - meta_file <- file.path(test_path("test_data"), "ld_meta_refinfo_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 <- refVariantInfo(meta_file, region = "chr21:17513228-17592874") - expect_true(is.data.frame(result)) - expect_equal(nrow(result), 349L) - expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(result))) - # .afreq is present, so allele_freq should be populated - expect_true("allele_freq" %in% names(result)) - expect_true(all(result$allele_freq > 0 & result$allele_freq < 1)) -}) - -test_that("refVariantInfo filters by subregion", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path( - test_path("test_data"), - "ld_meta_refinfo_sub_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 <- refVariantInfo(meta_file, region = "chr21:17513228-17550000") - expect_true(nrow(result) < 349L) - expect_true(all(result$pos >= 17513228 & result$pos <= 17550000)) -}) - -test_that("refVariantInfo returns variant info for VCF source", { skip_if_not_installed("VariantAnnotation") - meta_file <- file.path( - test_path("test_data"), - "ld_meta_refinfo_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( - refVariantInfo(meta_file, region = "chr21:17513228-17592874") - ) - expect_true(is.data.frame(result)) - expect_equal(nrow(result), 349L) - expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(result))) - expect_true("allele_freq" %in% names(result)) - expect_true(all(result$allele_freq > 0 & result$allele_freq < 1)) -}) - -test_that("refVariantInfo returns variant info for GDS source", { skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - meta_file <- file.path( - test_path("test_data"), - "ld_meta_refinfo_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 <- refVariantInfo(meta_file, region = "chr21:17513228-17592874") - expect_true(is.data.frame(result)) - expect_equal(nrow(result), 349L) - expect_true(all(c("chrom", "id", "pos", "A2", "A1") %in% names(result))) - expect_true("allele_freq" %in% names(result)) -}) - -test_that("refVariantInfo VCF filters by subregion", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Rsamtools") - meta_file <- file.path( - test_path("test_data"), - "ld_meta_refinfo_vcf_sub_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( - refVariantInfo(meta_file, region = "chr21:17513228-17550000") - ) - expect_true(nrow(result) < 349L) - expect_true(all(result$pos >= 17513228 & result$pos <= 17550000)) -}) - -test_that("refVariantInfo returns consistent results across formats", { - skip_if_not_installed("pgenlibr") - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - region <- "chr21:17513228-17592874" - td <- test_path("test_data") - - meta_plink <- file.path(td, "ld_meta_refinfo_cmp_p2_tmp.tsv") - meta_gds <- file.path(td, "ld_meta_refinfo_cmp_gds_tmp.tsv") - on.exit( - { - unlink(meta_plink) - unlink(meta_gds) - }, - add = TRUE - ) - - for (f in c(meta_plink, meta_gds)) { - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), f) + # A window over the first 8 of the 349 variants. PLINK2 reads the allele + # frequency from its .afreq sidecar, VCF and GDS from the dosages. + window <- GenomicRanges::GRanges("chr21:17513228-17515000") + sources <- c( + plink2 = "test_variants", + vcf = "test_variants.vcf.gz", + gds = "test_variants.gds" + ) + infos <- map(sources, .gioRefInfoViaMeta, which = window) + for (format in names(infos)) { + info <- infos[[format]] + expect_true(is.data.frame(info), info = format) + expect_true( + all( + c("chrom", "id", "pos", "A2", "A1", "allele_freq") %in% + names(info) + ), + info = format + ) + expect_true( + all(info$allele_freq > 0 & info$allele_freq < 1), + info = format + ) + expect_equal(nrow(info), 8L, info = format) + expect_true( + all(info$pos >= 17513228 & info$pos <= 17515000), + info = format + ) + expect_equal(info$pos, infos$plink2$pos, info = format) } - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_plink, - append = TRUE - ) - cat( - paste("21", "0", "0", "test_variants.gds", sep = "\t"), - "\n", - file = meta_gds, - append = TRUE - ) - - info_plink <- refVariantInfo(meta_plink, region = region) - info_gds <- refVariantInfo(meta_gds, region = region) - - expect_equal(nrow(info_plink), nrow(info_gds)) - expect_equal(info_plink$pos, info_gds$pos) }) # =========================================================================== @@ -794,13 +443,17 @@ test_that("readAfreq returns NULL when no afreq file exists", { expect_null(af) }) -test_that("readAfreq reads .afreq.zst file", { +test_that("readAfreq reads .afreq.zst in-process, preferring it to .afreq", { td <- test_path("test_data") - # test_harmonize_regions has both .afreq and .afreq.zst; readAfreq prefers .zst + # Empty PATH: no zstd (or any) CLI is reachable. archive decompresses the + # .zst in-process via libarchive, so the read must still succeed. + withr::local_envvar(PATH = "") + # test_harmonize_regions has both .afreq and .afreq.zst; readAfreq + # prefers the .zst. af <- readAfreq(file.path(td, "test_harmonize_regions")) expect_true(is.data.frame(af)) expect_true(all( - c("id", "A2", "A1", "alt_freq", "obs_ct") %in% colnames(af) + c("chrom", "id", "A2", "A1", "alt_freq", "obs_ct") %in% colnames(af) )) # This afreq has U_MIN/U_MAX columns expect_true(all(c("u_min", "u_max") %in% colnames(af))) @@ -808,14 +461,14 @@ test_that("readAfreq reads .afreq.zst file", { }) test_that("readAfreq reads plain .afreq with U_MIN/U_MAX", { - td <- test_path("test_data") - # Temporarily hide the .zst so readAfreq falls through to plain .afreq - zst_path <- file.path(td, "test_harmonize_regions.afreq.zst") - tmp_path <- paste0(zst_path, ".bak") - file.rename(zst_path, tmp_path) - on.exit(file.rename(tmp_path, zst_path), add = TRUE) - - af <- readAfreq(file.path(td, "test_harmonize_regions")) + # A copy with no .zst beside it, so readAfreq falls through to plain + # .afreq without the shared fixture being touched. + dir <- withr::local_tempdir() + file.copy( + test_path("test_data", "test_harmonize_regions.afreq"), + file.path(dir, "g.afreq") + ) + af <- readAfreq(file.path(dir, "g")) expect_true(is.data.frame(af)) expect_true(all(c("u_min", "u_max") %in% colnames(af))) expect_equal(nrow(af), 8L) @@ -884,8 +537,10 @@ test_that("matchVariantsToKeep returns all FALSE for non-matching variants", { # =========================================================================== test_that("matchVariantsToKeep works with single-column variant ID file", { + # The variant info is pecotmr's own (UCSC); the keep file may spell its + # chromosomes either way. vi <- data.frame( - chrom = c("1", "1", "1"), + chrom = c("chr1", "chr1", "chr1"), pos = c(100L, 200L, 300L), A2 = c("A", "C", "G"), A1 = c("G", "T", "A"), @@ -925,10 +580,10 @@ test_that("matchVariantsToKeep uses position-only matching when no alleles", { }) # =========================================================================== -# readGenotypes + extractblockgenotypes: plink2 tests (replacing load_plink2_data) +# readGenotypes + extractBlockGenotypes: plink2 tests # =========================================================================== -test_that("readGenotypes loads plink2 handle with all variants", { +test_that("readGenotypeHandle reads a plink2 fileset with all its variants", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") handle <- readGenotypeHandle( @@ -936,6 +591,7 @@ test_that("readGenotypes loads plink2 handle with all variants", { format = "plink2" ) expect_s4_class(handle, "GenotypeHandle") + expect_equal(genotypeFormat(handle), "plink2") expect_equal(nSamples(handle), 100L) expect_equal(nrow(snpInfo(handle)), 349L) rse <- extractBlockGenotypes(handle, seq_len(nrow(snpInfo(handle)))) @@ -945,42 +601,6 @@ test_that("readGenotypes loads plink2 handle with all variants", { expect_equal(ncol(dosage), 100L) }) -test_that("loadGenotypeRegion filters by region for plink2", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - region <- "chr21:17513228-17550000" - result <- loadGenotypeRegion( - file.path(td, "test_variants"), - region = region - ) - expect_true(ncol(result) < 349L) -}) - -test_that("loadGenotypeRegion errors on empty region for plink2", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - expect_error( - loadGenotypeRegion( - file.path(td, "test_variants"), - region = "chr21:1-2" - ), - "No SNPs found", - class = "NoSnpsError" - ) -}) - -test_that("loadGenotypeRegion removes indels for plink2", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - full <- loadGenotypeRegion(file.path(td, "test_variants")) - filtered <- loadGenotypeRegion( - file.path(td, "test_variants"), - keepIndel = FALSE - ) - # test data has 36 indels - expect_equal(ncol(filtered), ncol(full) - 36L) -}) - test_that("loadGenotypeRegion filters by keep_variants_path for plink2", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") @@ -1026,46 +646,6 @@ test_that("readGenotypes plink2 sample names match psam IIDs", { expect_equal(length(unique(sampleIds(handle))), 100L) }) -# ============================================================================= -# Removed during the post-S4-refactor cleanup -# ----------------------------------------------------------------------------- -# The following test blocks were deleted because the functions / classes they -# exercise were either removed outright or replaced by `.Deprecated()` no-op -# stubs in the S4 refactor (see R/fileUtils.R deprecation notices): -# -# * loadRegionalAssociationData -> use QtlDataset() -# * loadRegionalUnivariateData -> use QtlDataset() -# * loadRegionalRegressionData -> use QtlDataset() -# * loadRegionalMultivariateData -> use MultiStudyQtlDataset() -# * loadRegionalFunctionalData -> use QtlDataset() -# * loadMultitaskRegionalData -> use MultiStudyQtlDataset() -# * loadRssData -> use GwasSumStats() / QtlSumStats() + -# summaryStatsQc() -# * loadTwasWeights -> use TwasWeights() / twasWeightsRow() -# * regionDataToIndInput -> use QtlDataset() -# * regionDataToRssInput -> use QtlSumStats() / GwasSumStats() -# * phenoListToMat -> function removed (no replacement) -# -# Removed S4 classes (no longer constructible / inspectable): -# * RegionalData -# * MultivariateRegionalData -# * QcResult -# * AlleleQcResult -# -# Removed accessor / helper functions: -# * getrssinput, getlddata, getoutliernumber -# * rssBasicQc -> folded into summaryStatsQc() -# -# Removed pipeline wrappers (all `.Deprecated()` no-ops returning NULL): -# * colocWrapper, xqtlEnrichmentWrapper, colocPostProcessor, -# rssAnalysisPipeline -# -# No surgical renames were applied: the previous test file contained no -# references to `finemappingResult` / `FineMappingResult(variantNames=...)` or -# related identifiers, so no `$finemappingEntry` / -# `fineMappingRow(variantIds=...)` substitutions were necessary here. -# ============================================================================= - # Tests for genotype loading via readGenotypes + extractBlockGenotypes, # and the loadGenotypeRegion dispatcher. @@ -1074,26 +654,13 @@ test_data_dir <- test_path("test_data") plink_prefix <- file.path(test_data_dir, "test_variants") vcf_path <- file.path(test_data_dir, "test_variants.vcf.gz") gds_path <- file.path(test_data_dir, "test_variants.gds") -region_all <- "chr21:17513228-17592874" -region_sub <- "chr21:17513228-17550000" +# A window over the first 8 variants. +region_sub <- GenomicRanges::GRanges("chr21:17513228-17515000") # Expected dimensions n_samples <- 100L n_variants <- 349L -test_that("format detection supports dotted PLINK2 prefixes", { - tmp <- tempfile("plink2_dotted_prefix_") - prefix <- file.path(dirname(tmp), "ADSP.R4.EUR.chr21") - file.create( - paste0(prefix, ".pgen"), - paste0(prefix, ".pvar"), - paste0(prefix, ".psam") - ) - on.exit(unlink(paste0(prefix, c(".pgen", ".pvar", ".psam"))), add = TRUE) - - expect_equal(pecotmr:::.genotypePathFormat(prefix), "plink2") -}) - # Shared helper: validate the output structure from loadGenotypeRegion # (with returnVariantInfo=TRUE) checkGenotypeResult <- function( @@ -1110,230 +677,156 @@ checkGenotypeResult <- function( expect_equal(ncol(result$X), expected_ncol) expect_true(is.data.frame(result$variant_info)) expect_true(all( - c("chrom", "id", "pos", "A2", "A1") %in% names(result$variant_info) - )) - expect_equal(nrow(result$variant_info), expected_ncol) - # Column names of X match variant IDs - expect_equal(colnames(result$X), result$variant_info$id) - # Dosage values should be non-negative integers (0, 1, 2 for biallelic; - # multiallelic VCF sites can have higher values) - vals <- result$X[!is.na(result$X)] - expect_true(all(vals >= 0), label = paste(label, "dosage non-negative")) - expect_true( - all(vals == round(vals)), - label = paste(label, "dosage integer-valued") - ) -} - -# --- readGenotypes: PLINK1 (PlinkMatrix) ------------------------------------- - -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("PlinkMatrix") - # Use .genotype suffix plink1 files tested elsewhere in test_file_utils - plink1_path <- file.path(test_data_dir, "protocol_example.genotype") - skip_if( - !file.exists(paste0(plink1_path, ".bed")), - "plink1 test fixture missing" - ) - result <- loadGenotypeRegion(plink1_path, returnVariantInfo = TRUE) - expect_true(is.list(result)) - expect_true(is.matrix(result$X)) -}) - -# --- readGenotypes: PLINK2 (pgenlibr) ---------------------------------------- - -test_that("readGenotypes creates plink2 handle", { - skip_if_not_installed("pgenlibr") - handle <- readGenotypeHandle(plink_prefix, format = "plink2") - expect_s4_class(handle, "GenotypeHandle") - expect_equal(genotypeFormat(handle), "plink2") - expect_equal(nSamples(handle), n_samples) - expect_equal(nrow(snpInfo(handle)), n_variants) -}) - -test_that("extractBlockGenotypes works for plink2", { - skip_if_not_installed("pgenlibr") - handle <- readGenotypeHandle(plink_prefix, format = "plink2") - rse <- extractBlockGenotypes(handle, seq_len(nrow(snpInfo(handle)))) - expect_s4_class(rse, "SummarizedExperiment") - dosage <- SummarizedExperiment::assay(rse, "dosage") - expect_equal(nrow(dosage), n_variants) - expect_equal(ncol(dosage), n_samples) -}) - -test_that("loadGenotypeRegion filters plink2 by region", { - skip_if_not_installed("pgenlibr") - result <- loadGenotypeRegion( - plink_prefix, - region = region_sub, - returnVariantInfo = TRUE - ) - checkGenotypeResult(result, expected_ncol = 134L, label = "plink2 region") - expect_true(all( - result$variant_info$pos >= 17513228 & - result$variant_info$pos <= 17550000 - )) -}) - -test_that("loadGenotypeRegion filters plink2 indels", { - skip_if_not_installed("pgenlibr") - result <- loadGenotypeRegion( - plink_prefix, - keepIndel = FALSE, - returnVariantInfo = TRUE - ) - expect_lt(ncol(result$X), n_variants) - expect_true(all(nchar(result$variant_info$A1) == 1)) - expect_true(all(nchar(result$variant_info$A2) == 1)) -}) - -test_that("loadGenotypeRegion errors on empty region for plink2", { - skip_if_not_installed("pgenlibr") - expect_error(loadGenotypeRegion(plink_prefix, region = "chr1:1-2")) -}) - -# --- readGenotypes: VCF (VariantAnnotation) ----------------------------------- - -test_that("readGenotypes reads a VCF as a panel over its own seed", { - skip_if_not_installed("VariantAnnotation") - 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", { - skip_if_not_installed("VariantAnnotation") - result <- suppressWarnings(loadGenotypeRegion( - vcf_path, - returnVariantInfo = TRUE - )) - checkGenotypeResult(result, label = "dispatch vcf") -}) - -test_that("loadGenotypeRegion filters VCF by region", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Rsamtools") - result <- suppressWarnings(loadGenotypeRegion( - vcf_path, - region = region_sub, - returnVariantInfo = TRUE - )) - checkGenotypeResult(result, expected_ncol = 134L, label = "vcf region") - expect_true(all( - result$variant_info$pos >= 17513228 & - result$variant_info$pos <= 17550000 - )) -}) - -test_that("loadGenotypeRegion filters VCF indels", { - skip_if_not_installed("VariantAnnotation") - result <- suppressWarnings(loadGenotypeRegion( - vcf_path, - keepIndel = FALSE, - returnVariantInfo = TRUE + c("chrom", "id", "pos", "A2", "A1") %in% names(result$variant_info) )) - expect_lt(ncol(result$X), n_variants) - expect_true(all(nchar(result$variant_info$A1) == 1)) - expect_true(all(nchar(result$variant_info$A2) == 1)) -}) + expect_equal(nrow(result$variant_info), expected_ncol) + # Column names of X match variant IDs + expect_equal(colnames(result$X), result$variant_info$id) + # Dosage values should be non-negative integers (0, 1, 2 for biallelic; + # multiallelic VCF sites can have higher values) + vals <- result$X[!is.na(result$X)] + expect_true(all(vals >= 0), label = paste(label, "dosage non-negative")) + expect_true( + all(vals == round(vals)), + label = paste(label, "dosage integer-valued") + ) +} -# --- readGenotypes: GDS (SNPRelate) ------------------------------------------- +# --- readGenotypes: PLINK1, VCF and GDS panels ------------------------------- -test_that("readGenotypes reads a GDS file as a panel over its own seed", { +test_that("readGenotypes reads PLINK1, VCF and GDS files as panels", { + skip_if_not_installed("PlinkMatrix") + skip_if_not_installed("VariantAnnotation") skip_if_not_installed("gdsfmt") 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") + sources <- list( + plink1 = list(plink1Prefix = plink_prefix), + vcf = list(vcf_path), + gds = list(gds_path) + ) + for (format in names(sources)) { + panel <- exec(readGenotypes, !!!sources[[format]]) + expect_s4_class(panel, "RangedSummarizedExperiment") + expect_equal(dim(panel), c(n_variants, n_samples), info = format) + expect_equal( + S4Vectors::metadata(panel)$genotypeSource$format, + format, + info = format + ) + # No handle: the panel reads through its own GenotypeDosageSeed, and + # records where it came from itself. + expect_s4_class(pecotmr:::.panelSeed(panel), "GenotypeDosageSeed") + expect_null(pecotmr:::.ldRefHandle(panel), info = format) + } }) -test_that("loadGenotypeRegion loads GDS via dispatch", { +# --- loadGenotypeRegion ------------------------------------------------------- + +test_that("loadGenotypeRegion reads every format by its path, alike", { + skip_if_not_installed("PlinkMatrix") + skip_if_not_installed("pgenlibr") + skip_if_not_installed("VariantAnnotation") skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - result <- loadGenotypeRegion(gds_path, returnVariantInfo = TRUE) - checkGenotypeResult(result, label = "dispatch gds") + # A PLINK2 prefix, a PLINK1 .bed, a VCF and a GDS file of the same + # genotypes: each is told by its path and read to the same variants. + paths <- c( + plink2 = plink_prefix, + plink1 = paste0(plink_prefix, ".bed"), + vcf = vcf_path, + gds = gds_path + ) + loaded <- map(paths, loadGenotypeRegion, returnVariantInfo = TRUE) + for (format in names(paths)) { + checkGenotypeResult(loaded[[format]], label = format) + expect_equal( + loaded[[format]]$variant_info$pos, + loaded$plink2$variant_info$pos, + info = format + ) + } }) -test_that("loadGenotypeRegion filters GDS by region", { +test_that("loadGenotypeRegion filters each format to a region", { + skip_if_not_installed("pgenlibr") + skip_if_not_installed("VariantAnnotation") skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - result <- loadGenotypeRegion( - gds_path, - region = region_sub, - returnVariantInfo = TRUE - ) - checkGenotypeResult(result, expected_ncol = 134L, label = "gds region") - expect_true(all( - result$variant_info$pos >= 17513228 & - result$variant_info$pos <= 17550000 - )) + for (path in c(plink_prefix, vcf_path, gds_path)) { + result <- loadGenotypeRegion( + path, + which = region_sub, + returnVariantInfo = TRUE + ) + checkGenotypeResult(result, expected_ncol = 8L, label = path) + expect_true( + all( + result$variant_info$pos >= 17513228 & + result$variant_info$pos <= 17515000 + ), + info = path + ) + } }) -test_that("loadGenotypeRegion filters GDS indels", { +test_that("loadGenotypeRegion drops every format's indels", { + skip_if_not_installed("pgenlibr") + skip_if_not_installed("VariantAnnotation") skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - result <- loadGenotypeRegion( - gds_path, - keepIndel = FALSE, - returnVariantInfo = TRUE - ) - expect_lt(ncol(result$X), n_variants) - expect_true(all(nchar(result$variant_info$A1) == 1)) - expect_true(all(nchar(result$variant_info$A2) == 1)) + # The first 25 variants, 3 of them indels: a VCF is read a record at a + # time, so the filter is run over a window rather than the whole file. + window <- GenomicRanges::GRanges("chr21:17513228-17518122") + for (path in c(plink_prefix, vcf_path, gds_path)) { + result <- loadGenotypeRegion( + path, + which = window, + keepIndel = FALSE, + returnVariantInfo = TRUE + ) + expect_equal(ncol(result$X), 22L, info = path) + expect_true(all(nchar(result$variant_info$A1) == 1), info = path) + expect_true(all(nchar(result$variant_info$A2) == 1), info = path) + } }) -test_that("loadGenotypeRegion errors on empty region for GDS", { +test_that("loadGenotypeRegion errors on an empty region", { + skip_if_not_installed("pgenlibr") skip_if_not_installed("SNPRelate") skip_if_not_installed("gdsfmt") - expect_error(loadGenotypeRegion(gds_path, region = "chr1:1-2")) + # Off the panel's variants, or on a chromosome it does not hold. + for (path in c(plink_prefix, gds_path)) { + for (window in c("chr21:1-2", "chr1:1-2")) { + expect_error( + loadGenotypeRegion( + path, + which = GenomicRanges::GRanges(window) + ), + "No SNPs found", + class = "NoSnpsError", + info = str_c(path, " ", window) + ) + } + } }) -# --- Cross-format consistency ------------------------------------------------- - -test_that("all formats return same dimensions and positions via loadGenotypeRegion", { - skip_if_not_installed("PlinkMatrix") +test_that("loadGenotypeRegion returns matrix when returnVariantInfo=FALSE", { skip_if_not_installed("pgenlibr") - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("SNPRelate") + result <- loadGenotypeRegion(plink_prefix) + expect_true(is.matrix(result)) + expect_equal(nrow(result), n_samples) + expect_equal(ncol(result), n_variants) +}) - p2 <- loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) - p1 <- loadGenotypeRegion( - paste0(plink_prefix, ".bed"), - returnVariantInfo = TRUE +test_that("loadGenotypeRegion errors on unrecognized format", { + expect_error( + loadGenotypeRegion("/nonexistent/file.xyz"), + "loadGenotypeRegion: .* is neither a genotype file nor a PLINK prefix" ) - vcf <- suppressWarnings(loadGenotypeRegion( - vcf_path, - returnVariantInfo = TRUE - )) - 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) }) +# --- Cross-format consistency ------------------------------------------------- + test_that("PLINK1 and PLINK2 readGenotypes return consistent alleles", { skip_if_not_installed("PlinkMatrix") skip_if_not_installed("pgenlibr") @@ -1351,55 +844,6 @@ test_that("PLINK1 and PLINK2 readGenotypes return consistent alleles", { ) }) -# --- loadGenotypeRegion (dispatch) ----------------------------------------- - -test_that("loadGenotypeRegion dispatches to VCF by extension", { - skip_if_not_installed("VariantAnnotation") - result <- suppressWarnings(loadGenotypeRegion( - vcf_path, - returnVariantInfo = TRUE - )) - checkGenotypeResult(result, label = "dispatch vcf") -}) - -test_that("loadGenotypeRegion dispatches to GDS by extension", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - result <- loadGenotypeRegion(gds_path, returnVariantInfo = TRUE) - checkGenotypeResult(result, label = "dispatch gds") -}) - -test_that("loadGenotypeRegion dispatches to PLINK2 by prefix", { - skip_if_not_installed("pgenlibr") - result <- loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) - checkGenotypeResult(result, label = "dispatch plink2") -}) - -test_that("loadGenotypeRegion returns matrix when returnVariantInfo=FALSE", { - skip_if_not_installed("pgenlibr") - result <- loadGenotypeRegion(plink_prefix) - expect_true(is.matrix(result)) - expect_equal(nrow(result), n_samples) - expect_equal(ncol(result), n_variants) -}) - -test_that("loadGenotypeRegion applies region filter", { - skip_if_not_installed("pgenlibr") - result <- loadGenotypeRegion( - plink_prefix, - region = region_sub, - returnVariantInfo = TRUE - ) - expect_equal(ncol(result$X), 134L) -}) - -test_that("loadGenotypeRegion errors on unrecognized format", { - expect_error( - loadGenotypeRegion("/nonexistent/file.xyz"), - "loadGenotypeRegion: .* is neither a genotype file nor a PLINK prefix" - ) -}) - # =========================================================================== # Tests migrated from test_dataStructures.R (extractBlockGenotypes) # =========================================================================== @@ -1440,42 +884,6 @@ test_that("extractBlockGenotypes mean-imputes a missing call on request", { expect_equal(imputed[-2L, ], raw[-2L, ]) }) -# ============================================================================= -# adjustPips -# ============================================================================= - -# Build a minimal FineMappingRow with a known lbf_variable so PIP -# renormalization can be checked end-to-end. -.makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { - p <- length(vids) - set.seed(11L) - lbf <- matrix( - rnorm(maxNumSingleEffects * p), - nrow = maxNumSingleEffects, - ncol = p - ) - colnames(lbf) <- vids - alpha <- lbfToAlpha(lbf) - pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) - fineMappingRow( - variantIds = vids, - susieFit = list( - pip = pip, - alpha = alpha, - lbf_variable = lbf, - mu = matrix(0, maxNumSingleEffects, p), - X_column_scale_factors = rep(1, p) - ), - topLoci = data.frame( - variant_id = vids, - pip = pip, - betahat = rep(0, p), - sebetahat = rep(1, p), - stringsAsFactors = FALSE - ) - ) -} - # =========================================================================== # One-file-per-chromosome (sharded) handle: extraction routing. # extractBlockGenotypes() routes each region to its per-chromosome payload and @@ -1519,7 +927,7 @@ test_that("extractBlockGenotypes mean-imputes a missing call on request", { shard <- GenotypeHandle(genoMeta = c("21" = spec$p21, "22" = spec$p22)) expect_s4_class(shard, "GenotypeHandle") expect_equal(genotypeFormat(shard), genotypeFormat(ref21)) - expect_equal(sort(names(chromPaths(shard))), c("21", "22")) + expect_equal(sort(names(chromPaths(shard))), c("chr21", "chr22")) n21 <- nrow(snpInfo(ref21)) n22 <- nrow(snpInfo(ref22)) expect_equal(nrow(snpInfo(shard)), n21 + n22) @@ -1629,9 +1037,9 @@ 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, 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. +# validation, readStochasticMeta validation, the plink1 refVariantInfo path, +# a multi-range refVariantInfo region, and the non-integer dosages +# loadGenotypeRegion keeps without a sidecar. # =========================================================================== # --- readGenotypes dispatch + handle-constructor file-not-found stops -------- @@ -1672,6 +1080,16 @@ test_that("extractBlockGenotypes on a sharded handle handles an empty block", { expect_equal(colnames(dosage), sampleIds(shard)) }) +test_that("extractBlockGenotypes answers an empty index without a reader", { + # 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) + expect_equal(ncol(se), nSamples(gh)) +}) + test_that("sharded extraction errors for a chromosome with no payload", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") @@ -1691,7 +1109,7 @@ test_that("sharded extraction errors for a chromosome with no payload", { ) }) -# --- .extractBlockPlink2: stale-pointer reopen path (lines 402-403) ---------- +# --- .extractBlockPlink2: stale-pointer reopen path -------------------------- test_that("plink2 extraction reopens a stale (deserialized) pgen pointer", { skip_if_not_installed("pgenlibr") @@ -1717,45 +1135,7 @@ test_that("plink2 extraction reopens a stale (deserialized) pgen pointer", { expect_equal(got, ref) }) -# --- computeLd on a panel: NULL guard, single-variant, general path ---------- - -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("gdsfmt") - 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), rownames(panel)[1:6]) -}) - -test_that("computeLd returns identity for a single-variant block", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants"), - format = "plink2" - ) - R <- computeLd(handle, snpIdx = 1L, backend = "internal") - expect_equal(R, diag(1)) -}) - -test_that("computeLd on a panel computes via the general path", { - skip_if_not_installed("pgenlibr") - td <- test_path("test_data") - handle <- readGenotypeHandle( - file.path(td, "test_variants"), - format = "plink2" - ) - R <- computeLd(handle, snpIdx = 1:5, backend = "internal") - expect_equal(dim(R), c(5L, 5L)) - expect_equal(unname(diag(R)), rep(1, 5), tolerance = 1e-6) -}) +# --- computeLd on a panel: single-variant and general path ------------------ # --- genotype format detection ---------------------------------------------- @@ -1773,6 +1153,10 @@ test_that("a PLINK prefix is told by the PLINK file beside it", { pecotmr:::.genotypePathFormat(file.path(td, "test_variants")), "plink2" ) + # A dotted prefix's last part is not taken for an extension. + dotted <- file.path(withr::local_tempdir(), "ADSP.R4.EUR.chr21") + file.create(str_c(dotted, c(".pgen", ".pvar", ".psam"))) + expect_equal(pecotmr:::.genotypePathFormat(dotted), "plink2") # A GDS file is named by its own path, never by a stem beside it. stem <- tempfile("gioGdsStem_") file.create(paste0(stem, ".gds")) @@ -1873,26 +1257,6 @@ test_that("resolvePlink2Paths errors when .psam is missing", { ) }) -# --- readAfreq: .afreq.zst is read via archive, no external CLI -------------- - -test_that("readAfreq reads .afreq.zst without any external CLI", { - skip_if_not_installed("withr") - td <- test_path("test_data") - zdir <- tempfile("gioZst_") - dir.create(zdir) - file.copy( - file.path(td, "test_harmonize_regions.afreq.zst"), - file.path(zdir, "g.afreq.zst") - ) - # Empty PATH: no zstd (or any) CLI is reachable. archive decompresses the - # .zst in-process via libarchive, so the read must still succeed. - withr::local_envvar(PATH = "") - af <- readAfreq(file.path(zdir, "g")) - expect_true(is.data.frame(af)) - expect_equal(nrow(af), 8L) - expect_true(all(c("chrom", "id", "alt_freq") %in% colnames(af))) -}) - # --- readStochasticMeta: generic format missing required columns ------------- test_that("readStochasticMeta errors when generic file lacks required columns", { @@ -1924,7 +1288,7 @@ test_that("refVariantInfo reads variant info from a plink1 source", { expect_gt(nrow(info), 0L) }) -test_that("refVariantInfo applies a multi-row data.frame region filter", { +test_that("refVariantInfo applies a multi-range region filter", { skip_if_not_installed("pgenlibr") td <- test_path("test_data") meta_file <- file.path(td, "ld_meta_refinfo_multirow_tmp.tsv") @@ -1936,15 +1300,13 @@ test_that("refVariantInfo applies a multi-row data.frame region filter", { file = meta_file, append = TRUE ) - # A two-row region (both chr21) drives the multi-row branch of the filter - # loop; together the rows cover the full block. - region_df <- data.frame( - chrom = c("21", "21"), - start = c(17513228L, 17550001L), - end = c(17550000L, 17592874L), - stringsAsFactors = FALSE + # A two-range window (both chr21) drives the multi-range filter; together + # the ranges cover the full block. + twoRanges <- GenomicRanges::GRanges( + "21", + IRanges::IRanges(c(17513228L, 17550001L), c(17550000L, 17592874L)) ) - info <- refVariantInfo(meta_file, region = region_df) + info <- refVariantInfo(meta_file, which = twoRanges) expect_true(is.data.frame(info)) expect_equal(nrow(info), 349L) expect_true(all(info$pos >= 17513228 & info$pos <= 17592874)) @@ -2041,61 +1403,38 @@ test_that("extractBlockGenotypes honours request order (plink2)", { .gio_orderCheck("plink2", test_path("test_data", "test_variants")) }) -test_that("a PLINK1 panel honours request order", { +test_that("a PLINK1, GDS or delayed PLINK2 read 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. + # reads each block in file order and lays it out as asked. DelayedArray + # hands the index straight to extract_array(), so a handle's delayed + # array inherits whatever the reader does. 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") 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 = "plink2" + stem <- test_path("test_data", "test_variants") + arrays <- list( + plink1 = SummarizedExperiment::assay( + readGenotypes(plink1Prefix = stem), + "dosage" + ), + gds = SummarizedExperiment::assay( + readGenotypes(str_c(stem, ".gds")), + "dosage" + ), + plink2 = genotypeDelayedArray( + readGenotypeHandle(stem, format = "plink2") + ) ) - a <- genotypeDelayedArray(handle) 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("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 = "plink2" - ) - ids <- snpInfo(handle)$SNP[1:6] - shuffled <- ids[c(4L, 1L, 6L, 2L, 5L, 3L)] - 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]) + for (format in names(arrays)) { + a <- arrays[[format]] + expect_equal( + unname(as.matrix(a[perm, 1:4])), + unname(as.matrix(a[1:6, 1:4])[perm, , drop = FALSE]), + info = format + ) + } }) test_that(".restoreRequestedOrder refuses a short block", { @@ -2107,70 +1446,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 -# while the result scales with variants^2, so on a wide panel the input dwarfs -# the output and keeping it on disk is what makes a big block feasible. -# --------------------------------------------------------------------------- - -test_that("onDisk LD matches the in-memory path on complete data", { - skip_if_not_installed("SNPRelate") - 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, - snpIdx = idx, - backend = "snprelate", - onDisk = TRUE - ) - inMem <- computeLd(handle, snpIdx = idx) - # The fixture has no missing calls, which is the only regime where the - # two are meant to agree. - expect_equal(unname(onDisk), unname(inMem), tolerance = 1e-8) -}) - -test_that("onDisk LD labels and orders by the request", { - skip_if_not_installed("SNPRelate") - 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), - 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") - 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), - "GDS-backed panel" - ) - expect_error( - computeLd(gds, backend = "internal", onDisk = TRUE), - "only available for" - ) - expect_error( - computeLd(matrix(1, 4, 3), backend = "snprelate", onDisk = TRUE), - "must be one" - ) - expect_error( - computeLd(gds, method = "gcta", backend = "snprelate", onDisk = TRUE), - "sample correlation" - ) -}) - 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 @@ -2256,17 +1531,6 @@ test_that("a panel answers panel questions without the handle", { expect_true(all(is_in(c("SNP", "A1", "A2"), cn))) }) -test_that("computeLd accepts the panel readGenotypes returns", { - skip_if_not_installed("PlinkMatrix") - panel <- readGenotypes( - test_path("test_data", "test_variants"), - format = "plink1" - ) - R <- computeLd(panel, snpIdx = 1:5) - expect_equal(dim(R), c(5L, 5L)) - expect_equal(unname(diag(R)), rep(1, 5), tolerance = 1e-8) -}) - 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 @@ -2366,7 +1630,7 @@ test_that("a legacy handle without fileIdx is not subset", { format = "plink2", snpInfo = data.frame( SNP = c("a", "b", "c"), - CHR = "1", + CHR = "chr1", BP = 1:3, A1 = "A", A2 = "G", @@ -2422,7 +1686,7 @@ test_that("block extraction rejects a format it has no reader for", { format = "plink2", snpInfo = data.frame( SNP = "a", - CHR = "1", + CHR = "chr1", BP = 1L, A1 = "A", A2 = "G", @@ -2552,7 +1816,7 @@ test_that("a BGEN file's variants read as pecotmr's convention", { 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$CHR, rep("chr1", 5L)) expect_equal(si$SNP, c("chr1:100:A:G", sprintf("rs%d", 1:4))) expect_equal(si$BP, 100L * (1:5)) }) @@ -2785,9 +2049,15 @@ test_that("a BGEN file serves every genotype route", { c("#chr\tstart\tend\tpath", str_c("chr1\t1\t10000\t", fx$path)), meta ) - viaMeta <- readGenotypes(ldMeta = meta, region = "chr1:1-10000") + viaMeta <- readGenotypes( + ldMeta = meta, + block = GenomicRanges::GRanges("chr1:1-10000") + ) expect_equal(unname(.bgenPanelDosage(viaMeta)), want, tolerance = 1e-12) - loaded <- loadGenotypeRegion(fx$path, region = "chr1:1-10000") + loaded <- loadGenotypeRegion( + fx$path, + which = GenomicRanges::GRanges("chr1:1-10000") + ) expect_equal(unname(loaded), want, tolerance = 1e-12) expect_equal( refVariantInfo(fx$path)$pos, @@ -2849,10 +2119,6 @@ test_that("the BGEN dosage kernel reads any ploidy and allele count", { 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) { @@ -3123,19 +2389,6 @@ test_that("a PLINK1 panel reads the dosages snpStats reads", { ) }) -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", { @@ -3148,14 +2401,24 @@ test_that("a per-chromosome VCF, GDS or PLINK1 set stacks into one panel", { 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))) + n21 <- nrow(one21) + expect_equal(dim(stacked), c(n21 + nrow(one22), ncol(one21))) + expect_equal(rownames(stacked), c(rownames(one21), rownames(one22))) + # A VCF is read a record at a time, so the dosages are compared on + # each shard's first, second and last rows, either side of the join. + rows21 <- c(1L, 2L, n21) + rows22 <- c(1L, 2L, nrow(one22)) + dose22 <- .dose(one22[rows22, ]) + expect_equal( + .dose(stacked[c(rows21, n21 + rows22), ]), + rbind(.dose(one21[rows21, ]), dose22) + ) 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]]) + c(chr21 = recorded[[1L]], chr22 = recorded[[2L]]) ) # A stacked panel has no single seed to read through. expect_null(pecotmr:::.panelSeed(stacked)) @@ -3164,7 +2427,8 @@ test_that("a per-chromosome VCF, GDS or PLINK1 set stacks into one panel", { genoMeta = c("21" = p21, "22" = p22), chroms = "22" ) - expect_equal(.dose(only22), .dose(one22)) + expect_equal(rownames(only22), rownames(one22)) + expect_equal(.dose(only22[rows22, ]), dose22) } }) @@ -3188,3 +2452,109 @@ test_that("a set's shards hold the same samples, one chromosome each", { "appears in more than one per-chromosome file" ) }) + +# =========================================================================== +# Panels saved by an earlier version (.updatePanel) +# =========================================================================== + +# The saved panels are built by helper-savedObjects.R. + +test_that(".updatePanel reads a saved PLINK1 panel again through its backend", { + stem <- test_path("test_data", "test_variants") + fresh <- readGenotypes(stem, format = "plink1") + saved <- .savedHandlePanel(fresh, stem, "plink1") + SummarizedExperiment::colData(saved) <- S4Vectors::DataFrame( + age = seq_len(ncol(fresh)), + row.names = colnames(fresh) + ) + # Saved as it was held: a few variants and samples, out of file order. + saved <- saved[c(4L, 2L, 7L), c(3L, 1L)] + # As saved, its dosages go through a reader handles no longer have. + expect_error( + as.matrix(SummarizedExperiment::assay(saved)), + "Unsupported format.*plink1" + ) + up <- .updatePanel(saved) + expect_s4_class(.panelSeed(up), "GenotypeDosageSeed") + expect_identical(dimnames(up), dimnames(saved)) + expect_equal( + as.matrix(SummarizedExperiment::assay(up)), + as.matrix(SummarizedExperiment::assay(fresh))[c(4L, 2L, 7L), c(3L, 1L)] + ) + expect_identical( + SummarizedExperiment::colData(up), + SummarizedExperiment::colData(saved) + ) + expect_identical(.ldRefSource(up)$format, "plink1") + # Brought up to date, it is current, and a second update leaves it be. + expect_identical(.updatePanel(up), up) +}) + +test_that(".updatePanel gives a saved stochastic sketch its real n and AF", { + skip_if_not_installed("pgenlibr") + ref <- "pecotmr://extdata/ld_reference/chr22/protocol_example.LD.chr22" + fresh <- readGenotypes(.resolveGenotypeResourcePath(ref), format = "plink2") + saved <- .savedHandlePanel(fresh, ref, "plink2") + # Saved before sketches recorded them, it passes for real genotypes. + expect_false(.ldRefIsProjection(saved)) + up <- .updatePanel(saved) + expect_true(.ldRefIsProjection(up)) + expect_identical(.ldRefRealNSamples(up), .ldRefRealNSamples(fresh)) + expect_identical(.ldRefAf(up), .ldRefAf(fresh)) + expect_identical(dimnames(up), dimnames(saved)) + expect_identical(.updatePanel(up), up) +}) + +test_that(".updatePanel reads a saved per-chromosome panel again", { + files <- c( + chr21 = test_path("test_data", "test_variants.bed"), + chr22 = test_path("test_data", "test_variants_chr22.bed") + ) + fresh <- readGenotypes(genoMeta = files) + saved <- .savedHandlePanel(fresh, "per-chromosome", "plink1", files) + # One variant from each chromosome. + keep <- c(2L, nrow(fresh) - 1L) + up <- .updatePanel(saved[keep, ]) + expect_identical(dimnames(up), dimnames(fresh[keep, ])) + expect_equal( + as.matrix(SummarizedExperiment::assay(up)), + as.matrix(SummarizedExperiment::assay(fresh)[keep, ]) + ) + expect_identical(.updatePanel(up), up) +}) + +test_that(".updatePanel takes a saved bare handle as the panel over it", { + stem <- test_path("test_data", "test_variants") + fresh <- readGenotypes(stem, format = "plink1") + handle <- .ldRefHandle(.savedHandlePanel(fresh, stem, "plink1")) + up <- .updatePanel(handle) + expect_s4_class(.panelSeed(up), "GenotypeDosageSeed") + expect_identical(dimnames(up), dimnames(fresh)) +}) + +test_that(".updatePanel leaves a current panel, or no panel, as it is", { + expect_null(.updatePanel(NULL)) + stem <- test_path("test_data", "test_variants") + plink1 <- readGenotypes(stem, format = "plink1") + expect_identical(.updatePanel(plink1), plink1) + skip_if_not_installed("pgenlibr") + plink2 <- readGenotypes(stem, format = "plink2") + expect_identical(.updatePanel(plink2), plink2) +}) + +test_that(".updatePanel refuses a saved panel it cannot read again", { + stem <- test_path("test_data", "test_variants") + fresh <- readGenotypes(stem, format = "plink1") + gone <- .savedHandlePanel(fresh, file.path(tempdir(), "nowhere"), "plink1") + cnd <- tryCatch(.updatePanel(gone), error = identity) + expect_s3_class(cnd, "pecotmrUnreadablePanel") + expect_match(conditionMessage(cnd), "nowhere.*cannot be read") + # Its files are where they were, but no longer hold one of its variants. + moved <- .savedHandlePanel(fresh, stem, "plink1") + rr <- SummarizedExperiment::rowRanges(moved) + rr[1L] <- GenomicRanges::shift(rr[1L], 1L) + SummarizedExperiment::rowRanges(moved) <- rr + cnd <- tryCatch(.updatePanel(moved), error = identity) + expect_s3_class(cnd, "pecotmrUnreadablePanel") + expect_match(conditionMessage(cnd), "no longer hold every variant") +}) diff --git a/tests/testthat/test_h2Annotations.R b/tests/testthat/test_h2Annotations.R index 5fd8199f..53d0606f 100644 --- a/tests/testthat/test_h2Annotations.R +++ b/tests/testthat/test_h2Annotations.R @@ -1,8 +1,4 @@ -# Tests migrated from test_h2ClassesSumstats.R - -# === Tests migrated from test_h2ClassesSumstats.R (h2Annotations) === - -test_that(".annot_detect_format() detects bigwig, bed, ldsc_annot", { +test_that(".annotDetectFormat() detects bigwig, bed, ldsc_annot", { detect <- pecotmr:::.annotDetectFormat expect_equal(detect("path/to/file.bw"), "bigwig") @@ -15,10 +11,10 @@ test_that(".annot_detect_format() detects bigwig, bed, ldsc_annot", { }) # ============================================================================= -# .read_bed_annotation (h2Annotations.R) +# .readBedAnnotation (h2Annotations.R) # ============================================================================= -test_that(".read_bed_annotation returns correct binary overlap vector", { +test_that(".readBedAnnotation returns correct binary overlap vector", { skip_if_not_installed("rtracklayer") bed_content <- paste( @@ -51,7 +47,7 @@ test_that(".read_bed_annotation returns correct binary overlap vector", { }) -test_that(".read_bed_annotation returns all zeros when no overlaps", { +test_that(".readBedAnnotation returns all zeros when no overlaps", { skip_if_not_installed("rtracklayer") bed_content <- "chr1\t100\t200\tregion1" @@ -70,10 +66,10 @@ test_that(".read_bed_annotation returns all zeros when no overlaps", { }) # ============================================================================= -# .read_ldsc_annot (h2Annotations.R) +# .readLdscAnnot (h2Annotations.R) # ============================================================================= -test_that(".read_ldsc_annot reads annotation column and matches SNPs", { +test_that(".readLdscAnnot reads annotation column and matches SNPs", { annot_df <- data.frame( CHR = c(1, 1, 1, 1), BP = c(100, 200, 300, 400), @@ -105,7 +101,7 @@ test_that(".read_ldsc_annot reads annotation column and matches SNPs", { }) -test_that(".read_ldsc_annot returns 0 for unmatched SNP positions", { +test_that(".readLdscAnnot returns 0 for unmatched SNP positions", { annot_df <- data.frame( CHR = c(1, 1), BP = c(100, 200), @@ -135,7 +131,7 @@ test_that(".read_ldsc_annot returns 0 for unmatched SNP positions", { }) -test_that(".read_ldsc_annot errors when annotation column not found", { +test_that(".readLdscAnnot errors when annotation column not found", { annot_df <- data.frame( CHR = c(1), BP = c(100), @@ -166,7 +162,7 @@ test_that(".read_ldsc_annot errors when annotation column not found", { }) -test_that(".read_ldsc_annot handles chr-prefixed CHR column", { +test_that(".readLdscAnnot handles chr-prefixed CHR column", { annot_df <- data.frame( CHR = c("chr1", "chr1"), BP = c(100, 200), @@ -195,10 +191,10 @@ test_that(".read_ldsc_annot handles chr-prefixed CHR column", { }) # ============================================================================= -# readannotations method (h2Annotations.R) +# readAnnotations method (h2Annotations.R) # ============================================================================= -test_that("readannotations errors when paths is not named", { +test_that("readAnnotations errors when path is not named", { snp_gr <- GenomicRanges::GRanges( seqnames = "chr1", ranges = IRanges::IRanges(start = 100, width = 1) @@ -206,12 +202,12 @@ test_that("readannotations errors when paths is not named", { expect_error( readAnnotations(c("/some/file.bed"), snp_gr), - "paths.*must be a named" + "path.*must be a named" ) }) -test_that("readannotations with BED file creates AnnotationMatrix", { +test_that("readAnnotations with BED file creates AnnotationMatrix", { skip_if_not_installed("rtracklayer") bed_content <- "chr1\t100\t500\tregion1" @@ -240,7 +236,7 @@ test_that("readannotations with BED file creates AnnotationMatrix", { }) -test_that("readannotations with LDSC annot file creates AnnotationMatrix", { +test_that("readAnnotations with LDSC annot file creates AnnotationMatrix", { annot_df <- data.frame( CHR = c(1, 1, 1), BP = c(100, 200, 300), @@ -273,7 +269,7 @@ test_that("readannotations with LDSC annot file creates AnnotationMatrix", { }) -test_that("readannotations uses provided annotation_meta", { +test_that("readAnnotations uses the provided annotationMeta", { annot_df <- data.frame( CHR = c(1, 1), BP = c(100, 200), @@ -314,7 +310,7 @@ test_that("readannotations uses provided annotation_meta", { }) -test_that("readannotations with multiple files creates multi-column matrix", { +test_that("readAnnotations with multiple files creates multi-column matrix", { # Two LDSC annot files annot_df1 <- data.frame( CHR = c(1, 1), @@ -429,9 +425,3 @@ test_that(".readLdscAnnot errors when CHR/BP columns are absent", { "must contain CHR and BP columns" ) }) - -# ============================================================================= -# readsumstats edge cases (h2_sumstats.R) -# ============================================================================= - -# ============================================================================= diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index 579243da..a0f481d3 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -4,6 +4,42 @@ context("h2_estimate_wrappers") # Helper functions to build test S4 objects # =========================================================================== +# 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) + })) +} + makeTestEigenRef <- function(nSnps = 20, nBlocks = 2) { snps_per_block <- nSnps / nBlocks blocks_gr <- GenomicRanges::GRanges( @@ -126,72 +162,22 @@ makeTestAnnotations <- function(nSnps = 20) { AnnotationMatrix(annot_mat, snp_ranges, annotation_meta, genome = "hg19") } -makeTestH2Estimate <- function(with_enrichment = TRUE) { - enrich <- if (with_enrichment) { - data.frame( - annotation = c("annot1", "annot2"), - tau = c(1e-7, 2e-7), - tauSe = c(5e-8, 6e-8), - enrichment = c(2.0, 3.0), - enrichmentSe = c(0.5, 0.7), - enrichmentP = c(0.01, 0.001), - propH2 = c(0.3, 0.5), - propSnps = c(0.15, 0.17), - stringsAsFactors = FALSE - ) - } else { - NULL - } - - set.seed(55) - annotationJackknifeCoefs <- if (with_enrichment) { - matrix( - rnorm(20), - nrow = 10, - ncol = 2, - dimnames = list(NULL, c("annot1", "annot2")) - ) - } else { - NULL - } - - new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.01, - interceptSe = 0.02, - localBlocks = NULL, - enrichment = enrich, - annotationJackknifeCoefs = annotationJackknifeCoefs, - scoreStats = NULL, - method = "lder", - nSnps = 100L, - traitName = "test" - ) -} - # =========================================================================== -# .validate_method_ref (internal) +# .validateMethodRef (internal) # =========================================================================== -test_that(".validate_method_ref errors when method='lder' but ref is LdScore", { - score_ref <- makeTestScoreRef() - expect_error( - pecotmr:::.validateMethodRef("lder", score_ref), - "requires an LdEigen" - ) -}) - -test_that(".validate_method_ref errors when method='hdl' but ref is LdScore", { +test_that(".validateMethodRef errors when lder or hdl is given an LdScore", { score_ref <- makeTestScoreRef() - expect_error( - pecotmr:::.validateMethodRef("hdl", score_ref), - "requires an LdEigen" - ) + for (method in c("lder", "hdl")) { + expect_error( + pecotmr:::.validateMethodRef(method, score_ref), + "requires an LdEigen", + info = method + ) + } }) -test_that(".validate_method_ref errors when method='gldsc' but ref is LdEigen", { +test_that(".validateMethodRef errors when method='gldsc' but ref is LdEigen", { eigen_ref <- makeTestEigenRef() expect_error( pecotmr:::.validateMethodRef("gldsc", eigen_ref), @@ -199,7 +185,7 @@ test_that(".validate_method_ref errors when method='gldsc' but ref is LdEigen", ) }) -test_that(".validate_method_ref returns TRUE for valid combinations", { +test_that(".validateMethodRef returns TRUE for valid combinations", { eigen_ref <- makeTestEigenRef() score_ref <- makeTestScoreRef() @@ -212,18 +198,13 @@ test_that(".validate_method_ref returns TRUE for valid combinations", { # computeLdScores for LdEigen # =========================================================================== -test_that("computeLdScores LdEigen returns matrix with base_l2 column", { +test_that("computeLdScores LdEigen returns a non-negative base_l2 column", { eigen_ref <- makeTestEigenRef() result <- computeLdScores(eigen_ref) expect_true(is.matrix(result)) expect_equal(ncol(result), 1) expect_equal(colnames(result), "base_l2") expect_equal(nrow(result), length(eigen_ref)) -}) - -test_that("computeLdScores LdEigen base LD scores are non-negative", { - eigen_ref <- makeTestEigenRef() - result <- computeLdScores(eigen_ref) expect_true(all(result[, "base_l2"] >= 0)) }) @@ -233,15 +214,8 @@ test_that("computeLdScores LdEigen with annotations returns base + annotation co result <- computeLdScores(eigen_ref, annotations = annot) expect_true(is.matrix(result)) # base_l2 + 2 annotation columns - expect_equal(ncol(result), 3) expect_equal(nrow(result), length(eigen_ref)) -}) - -test_that("computeLdScores LdEigen annotation column names match", { - eigen_ref <- makeTestEigenRef() - annot <- makeTestAnnotations() - result <- computeLdScores(eigen_ref, annotations = annot) expect_equal(colnames(result), c("base_l2", "annot_A", "annot_B")) }) @@ -419,84 +393,6 @@ test_that("computeLdScores LdScore with annotations but no ld_matrix_list errors ) }) -# =========================================================================== -# H2Estimate accessors -# =========================================================================== - -test_that("getlocal returns the local slot", { - local_df <- data.frame( - blockId = 1:3, - h2Local = c(0.1, 0.15, 0.05), - h2LocalSe = c(0.02, 0.03, 0.01), - stringsAsFactors = FALSE - ) - h2_obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = local_df, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = NULL, - method = "lder", - nSnps = 100L, - traitName = "test" - ) - expect_identical(localH2Blocks(h2_obj), local_df) -}) - -test_that("getenrichment returns the enrichment slot", { - h2_obj <- makeTestH2Estimate(with_enrichment = TRUE) - result <- stratifiedHeritabilityEnrichment(h2_obj) - expect_true(is.data.frame(result)) - expect_equal(result$annotation, c("annot1", "annot2")) -}) - -test_that("getscorestats returns the scoreStats slot", { - scoreStats <- list( - z = c(1.5, -0.8), - R = diag(2), - annotationNames = c("a1", "a2") - ) - h2_obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = scoreStats, - method = "lder", - nSnps = 100L, - traitName = "test" - ) - expect_identical(scoreStats(h2_obj), scoreStats) -}) - -test_that("accessors return NULL when slots are NULL", { - h2_obj <- new( - "H2Estimate", - estimate = 0.3, - estimateSe = 0.05, - intercept = 1.0, - interceptSe = 0.01, - localBlocks = NULL, - enrichment = NULL, - annotationJackknifeCoefs = NULL, - scoreStats = NULL, - method = "lder", - nSnps = 100L, - traitName = "test" - ) - expect_null(localH2Blocks(h2_obj)) - expect_null(stratifiedHeritabilityEnrichment(h2_obj)) - expect_null(scoreStats(h2_obj)) -}) - # =========================================================================== # h2EstimateToSldscTrait # =========================================================================== @@ -617,22 +513,29 @@ makeTestSumstatsForRef <- function( } # =========================================================================== -# estimateh2 end-to-end tests +# estimateH2 end-to-end tests # =========================================================================== -test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", { +test_that("estimateH2 returns an H2Estimate for lder, gldsc and hdl", { eigen_ref <- makeTestEigenRef() - ss <- makeTestSumstatsForRef(eigen_ref) - result <- estimateH2(ss, eigen_ref, method = "lder") - - expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(heritabilityEstimate(result))) - expect_true(is.numeric(heritabilityEstimateSe(result))) - expect_true(is.numeric(heritabilityIntercept(result))) - expect_true(is.numeric(heritabilityInterceptSe(result))) - expect_equal(methodNames(result), "lder") - expect_equal(nSnps(result), nSnps(ss)) - expect_equal(traitNames(result), "test") + refs <- list( + lder = eigen_ref, + gldsc = makeTestScoreRef(with_ld_matrices = TRUE), + hdl = eigen_ref + ) + for (method in names(refs)) { + ss <- makeTestSumstatsForRef(refs[[method]]) + result <- estimateH2(ss, refs[[method]], method = method) + + expect_true(is(result, "H2Estimate"), info = method) + expect_true(is.numeric(heritabilityEstimate(result)), info = method) + expect_true(is.numeric(heritabilityEstimateSe(result)), info = method) + expect_true(is.numeric(heritabilityIntercept(result)), info = method) + expect_true(is.numeric(heritabilityInterceptSe(result)), info = method) + expect_equal(methodNames(result), method, info = method) + expect_equal(nSnps(result), nSnps(ss), info = method) + expect_equal(traitNames(result), "test", info = method) + } }) # =========================================================================== @@ -747,7 +650,10 @@ 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"), "each LD block's LD") + expect_error( + estimateH2(ss, noMat, method = "gldsc"), + "g-LDSC needs each LD block's LD" + ) res <- estimateH2(ss, noMat, method = "sldsc") expect_s4_class(res, "H2Estimate") expect_equal(methodNames(res), "sldsc") @@ -955,16 +861,17 @@ test_that("buildLdScore(keepLdMatrices = FALSE) is rejected by g-LDSC", { test_that("estimateH2 accepts a chr-prefix difference between the two sides", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) - # makeTestSumstatsForRef already strips the prefix ("1" vs "chr1"), - # so this pins that the check normalizes rather than rejects it. + # makeTestSumstatsForRef builds the entry on bare names ("1" vs the + # reference's "chr1"); the constructor reads them in UCSC style, so the + # two sides meet exactly. expect_equal( as.character(GenomicRanges::seqnames(sumStats(ss)))[[1]], - "1" + "chr1" ) expect_s4_class(estimateH2(ss, ref, method = "lder"), "H2Estimate") }) -test_that("estimateh2 with var_y correction runs without error", { +test_that("estimateH2 with a varY correction runs without error", { eigen_ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef( eigen_ref, @@ -978,36 +885,6 @@ test_that("estimateh2 with var_y correction runs without error", { expect_true(is.numeric(heritabilityEstimate(result))) }) -test_that("estimateh2 with method='gldsc' returns H2Estimate", { - score_ref <- makeTestScoreRef(with_ld_matrices = TRUE) - ss <- makeTestSumstatsForRef(score_ref) - result <- estimateH2(ss, score_ref, method = "gldsc") - - expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(heritabilityEstimate(result))) - expect_true(is.numeric(heritabilityEstimateSe(result))) - expect_equal(methodNames(result), "gldsc") - expect_equal(nSnps(result), nSnps(ss)) - expect_equal(traitNames(result), "test") -}) - -test_that("estimateh2 with method='hdl' returns H2Estimate", { - eigen_ref <- makeTestEigenRef() - ss <- makeTestSumstatsForRef(eigen_ref) - # HDL likelihood optimization on tiny test data produces NaN warnings - # from log() on negative sigma2 during search; these are harmless. - suppressWarnings( - result <- estimateH2(ss, eigen_ref, method = "hdl") - ) - - expect_s4_class(result, "H2Estimate") - expect_true(is.numeric(heritabilityEstimate(result))) - expect_true(is.numeric(heritabilityEstimateSe(result))) - expect_equal(methodNames(result), "hdl") - expect_equal(nSnps(result), nSnps(ss)) - expect_equal(traitNames(result), "test") -}) - # =========================================================================== # computeLdScores for LdScore WITH annotations # =========================================================================== @@ -1037,11 +914,6 @@ test_that(".jackknifeSeFromLoo is zero when every LOO estimate is equal", { expect_equal(pecotmr:::.jackknifeSeFromLoo(rep(2, 5)), 0) }) -test_that(".jackknifeSeFromLoo is positive when the LOO estimates vary", { - set.seed(42) - expect_gt(pecotmr:::.jackknifeSeFromLoo(rnorm(10, mean = 5, sd = 0.5)), 0) -}) - 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 @@ -1061,7 +933,7 @@ test_that(".jackknifeSeFromLoo equals the pseudo-value jackknife", { # computeBaselineEnrichment # ============================================================================= -test_that("computeBaselineEnrichment returns correct structure", { +test_that("computeBaselineEnrichment computes enrichment and propSnps", { M <- 100 baseline_mat <- matrix(0, nrow = M, ncol = 2) baseline_mat[1:50, 1] <- 1 @@ -1091,45 +963,7 @@ test_that("computeBaselineEnrichment returns correct structure", { ) expect_named(res, expected_cols) expect_equal(nrow(res), 2) -}) - -test_that("computeBaselineEnrichment computes enrichment = tau * M / h2", { - M <- 100 - baseline_mat <- matrix(0, nrow = M, ncol = 2) - baseline_mat[1:50, 1] <- 1 - baseline_mat[, 2] <- 1 - tau <- c(0.01, 0.005) - tauSe <- c(0.002, 0.001) - h2 <- 0.5 - annot_names <- c("annot1", "base") - res <- pecotmr:::computeBaselineEnrichment( - tau, - tauSe, - NULL, - baseline_mat, - annot_names, - h2 - ) expect_equal(res$enrichment, tau * M / h2) -}) - -test_that("computeBaselineEnrichment computes propSnps correctly", { - M <- 100 - baseline_mat <- matrix(0, nrow = M, ncol = 2) - baseline_mat[1:50, 1] <- 1 - baseline_mat[, 2] <- 1 - tau <- c(0.01, 0.005) - tauSe <- c(0.002, 0.001) - h2 <- 0.5 - annot_names <- c("annot1", "base") - res <- pecotmr:::computeBaselineEnrichment( - tau, - tauSe, - NULL, - baseline_mat, - annot_names, - h2 - ) expect_equal(res$propSnps, c(0.5, 1.0)) }) @@ -1161,10 +995,10 @@ test_that("computeBaselineEnrichment uses jackknife blocks when provided", { }) # ============================================================================= -# standardize_tau_star +# standardizeTauStar # ============================================================================= -test_that("standardize_tau_star computes tauStar = tau * sd_annot * M_ref / h2g", { +test_that("standardizeTauStar computes tauStar = tau * sdAnnot * MRef / h2g", { tau <- c(0.01, 0.02) sd_annot <- c(0.5, 0.3) M_ref <- 1000L @@ -1183,11 +1017,13 @@ test_that("standardize_tau_star computes tauStar = tau * sd_annot * M_ref / h2g" h2g ) expected <- tau * sd_annot * M_ref / h2g + expect_true(is.list(res)) + expect_named(res, c("tauStar", "tauStarSe")) expect_equal(res$tauStar, expected) expect_length(res$tauStarSe, 2) }) -test_that("standardize_tau_star errors when h2g == 0", { +test_that("standardizeTauStar errors when h2g == 0", { expect_error( pecotmr:::standardizeTauStar( c(0.01), @@ -1200,7 +1036,7 @@ test_that("standardize_tau_star errors when h2g == 0", { ) }) -test_that("standardize_tau_star errors when tau and sd_annot differ in length", { +test_that("standardizeTauStar errors when tau and sdAnnot differ in length", { expect_error( pecotmr:::standardizeTauStar( c(0.01, 0.02), @@ -1213,34 +1049,11 @@ test_that("standardize_tau_star errors when tau and sd_annot differ in length", ) }) -test_that("standardize_tau_star returns list with tauStar and tauStarSe", { - tau <- c(0.01) - 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 - ) - expect_true(is.list(res)) - expect_named(res, c("tauStar", "tauStarSe")) - expect_length(res$tauStar, 1) - expect_length(res$tauStarSe, 1) -}) - # ============================================================================= -# meta_random_effects +# .rmaMeta # ============================================================================= -test_that("meta_random_effects returns all NA with k=0", { +test_that(".rmaMeta returns all NA with k=0", { res <- pecotmr:::.rmaMeta(numeric(0), numeric(0)) expect_true(is.na(res$mean)) expect_true(is.na(res$se)) @@ -1249,14 +1062,14 @@ test_that("meta_random_effects returns all NA with k=0", { expect_true(is.na(res$Q)) }) -test_that("meta_random_effects with k=1 returns input values", { +test_that(".rmaMeta with k=1 returns input values", { res <- pecotmr:::.rmaMeta(5.0, 1.0) expect_equal(res$mean, 5.0) expect_equal(res$se, 1.0) expect_equal(res$tau2, 0) }) -test_that("meta_random_effects with identical means gives tau2=0", { +test_that(".rmaMeta with identical means gives tau2=0", { means <- rep(3.0, 5) ses <- rep(1.0, 5) res <- pecotmr:::.rmaMeta(means, ses) @@ -1264,20 +1077,7 @@ test_that("meta_random_effects with identical means gives tau2=0", { expect_equal(res$mean, 3.0) }) -test_that("meta_random_effects returns correct structure", { - set.seed(42) - means <- rnorm(5, mean = 2, sd = 0.5) - ses <- rep(0.5, 5) - res <- pecotmr:::.rmaMeta(means, ses) - expect_true(is.list(res)) - expect_named(res, c("mean", "se", "tau2", "I2", "Q")) - expect_true(res$se > 0) - expect_true(res$I2 >= 0 && res$I2 <= 1) - expect_true(res$Q >= 0) - expect_true(res$tau2 >= 0) -}) - -test_that("meta_random_effects errors with non-positive ses", { +test_that(".rmaMeta errors with non-positive ses", { expect_error( pecotmr:::.rmaMeta(c(1, 2), c(1, 0)), "all ses must be positive and finite" @@ -1288,11 +1088,16 @@ test_that("meta_random_effects errors with non-positive ses", { ) }) -test_that("meta_random_effects known DerSimonian-Laird example", { +test_that(".rmaMeta defaults to DL and matches a known example", { # Three studies with known values means <- c(0.5, 0.8, 0.3) ses <- c(0.2, 0.3, 0.15) res <- pecotmr:::.rmaMeta(means, ses) + expect_equal(res, pecotmr:::.rmaMeta(means, ses, method = "DL")) + expect_true(is.list(res)) + expect_named(res, c("mean", "se", "tau2", "I2", "Q")) + # metafor reports I2 as a percentage; .rmaMeta rescales it to [0, 1]. + expect_true(res$I2 >= 0 && res$I2 <= 1) # Fixed-effect weights w_fe <- 1 / ses^2 @@ -1310,6 +1115,29 @@ test_that("meta_random_effects known DerSimonian-Laird example", { expect_equal(res$se, se_re) }) +test_that(".rmaMeta runs REML through metafor, differing from DL", { + set.seed(3) + m <- rnorm(8, sd = 1.5) + s <- abs(rnorm(8)) + 0.3 + reml <- pecotmr:::.rmaMeta(m, s, method = "REML") + expect_true(all(c("mean", "se", "tau2", "I2", "Q") %in% names(reml))) + expect_true(reml$I2 >= 0 && reml$I2 <= 1) + # REML tau2 generally differs from DL tau2 on heterogeneous data + expect_false(isTRUE(all.equal(reml$tau2, pecotmr:::.rmaMeta(m, s)$tau2))) +}) + +test_that(".rmaMeta falls back to DL when REML does not converge", { + # metafor's iterative estimators can fail to converge on small / degenerate + # inputs; .rmaMeta must still return a finite fit (via the DL fallback). + set.seed(1) + for (i in seq_len(25)) { + m <- rnorm(sample(3:8, 1L)) + s <- abs(rnorm(length(m))) + 0.1 + r <- suppressWarnings(pecotmr:::.rmaMeta(m, s, method = "REML")) + expect_true(is.finite(r$mean) && is.finite(r$se)) + } +}) + # ============================================================================= # snpsPerBlock # ============================================================================= @@ -1415,10 +1243,8 @@ test_that("checkGenomeBuild works with AnnotationMatrix", { expect_true(pecotmr:::checkGenomeBuild(am, ld_blocks)) }) -# Tests for heritability estimation methods: -# lderUnivariate (h2Lder.R) -# gldscUnivariate (h2Gldsc.R) -# hdlUnivariate (h2Hdl.R) +# Tests for the heritability estimators lderUnivariate, gldscUnivariate and +# hdlUnivariate. set.seed(42) @@ -1527,441 +1353,6 @@ simulateH2Data <- function( ) } -# Annotation helper: all-ones baseline so the eigenvalue-score column is -# simply the eigenvalue itself (avoids singularity with few blocks), plus -# one candidate annotation for score-statistic testing. -makeTestAnnotations <- function(n_snps) { - set.seed(99) - snp_gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", n_snps), - ranges = IRanges::IRanges( - start = seq(50, by = 100, length.out = n_snps), - width = 1L - ) - ) - # All-ones baseline (behaves like the unstratified intercept) - base_col <- rep(1, n_snps) - # Binary candidate: random 30% - cand_col <- rbinom(n_snps, 1, 0.3) - mat <- cbind(base_col, cand_col) - meta <- data.frame( - name = c("baseline1", "candidate1"), - tier = c("baseline", "candidate"), - type = c("binary", "binary"), - stringsAsFactors = FALSE - ) - AnnotationMatrix(mat, snp_gr, meta, genome = "hg19") -} - -# Pre-compute shared test data -dat <- simulateH2Data() - -# ============================================================================= -# LDER tests (h2Lder.R) -# ============================================================================= - -test_that("lderUnivariate returns correct structure", { - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_type(res, "list") - expect_true(all( - c( - "h2", - "h2Se", - "intercept", - "interceptSe", - "local", - "enrichment", - "annotationJackknifeCoefs", - "scoreStats" - ) %in% - names(res) - )) -}) - -test_that("lderUnivariate h2 is finite and in reasonable range", { - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_true(is.finite(res$h2)) - expect_true(res$h2 > -0.5 && res$h2 < 1.0) -}) - -test_that("lderUnivariate h2Se is positive", { - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_true(is.finite(res$h2Se)) - expect_true(res$h2Se > 0) -}) - -test_that("lderUnivariate intercept is near zero for well-calibrated data", { - # In LDER the intercept parameter a represents confounding deviation: - # the model is E[chi2Rot - 1] = n * h2/M * d + n * a - # so a ~ 0 when there is no confounding. - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_true(is.finite(res$intercept)) - expect_true(abs(res$intercept) < 0.01) -}) - -test_that("lderUnivariate with local = TRUE returns local data.frame", { - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref, local = TRUE) - expect_true(is.data.frame(res$local)) - expect_true("h2Local" %in% colnames(res$local)) -}) - -test_that("lderUnivariate without annotations returns NULL enrichment", { - res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_null(res$enrichment) -}) - -# ============================================================================= -# gLDSC tests (h2Gldsc.R) -# ============================================================================= - -test_that("gldscUnivariate returns correct structure", { - res <- pecotmr:::gldscUnivariate(dat$z, dat$n, dat$ld_score_ref) - expect_type(res, "list") - expect_true(all( - c( - "h2", - "h2Se", - "intercept", - "interceptSe", - "local", - "enrichment", - "annotationJackknifeCoefs", - "scoreStats" - ) %in% - names(res) - )) -}) - -test_that("gldscUnivariate h2 is finite", { - res <- pecotmr:::gldscUnivariate(dat$z, dat$n, dat$ld_score_ref) - expect_true(is.finite(res$h2)) -}) - -test_that("gldscUnivariate h2Se is positive", { - res <- pecotmr:::gldscUnivariate(dat$z, dat$n, dat$ld_score_ref) - expect_true(is.finite(res$h2Se)) - expect_true(res$h2Se > 0) -}) - -test_that("gldscUnivariate with local = TRUE returns per-block local h2", { - res <- pecotmr:::gldscUnivariate( - dat$z, - dat$n, - dat$ld_score_ref, - local = TRUE - ) - expect_true(is.data.frame(res$local)) - expect_true(all( - c("blockId", "h2Local", "h2LocalSe") %in% colnames(res$local) - )) -}) - -# ============================================================================= -# HDL tests (h2Hdl.R) -# ============================================================================= - -test_that("hdlUnivariate returns correct structure", { - res <- pecotmr:::hdlUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_type(res, "list") - expect_true(all( - c( - "h2", - "h2Se", - "intercept", - "interceptSe", - "local", - "enrichment", - "annotationJackknifeCoefs", - "scoreStats" - ) %in% - names(res) - )) -}) - -test_that("hdlUnivariate h2 is finite", { - res <- pecotmr:::hdlUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_true(is.finite(res$h2)) -}) - -test_that("hdlUnivariate h2Se is positive", { - res <- pecotmr:::hdlUnivariate(dat$z, dat$n, dat$eigen_ref) - expect_true(is.finite(res$h2Se)) - expect_true(res$h2Se > 0) -}) - -test_that("hdlUnivariate with local = TRUE returns local data.frame", { - res <- pecotmr:::hdlUnivariate(dat$z, dat$n, dat$eigen_ref, local = TRUE) - expect_true(is.data.frame(res$local)) - expect_true("h2Local" %in% colnames(res$local)) -}) - -# ============================================================================= -# Annotation tests (using LDER with more blocks for numerical stability) -# ============================================================================= - -# Use 5 blocks and 500 SNPs for annotation tests to avoid singular matrices -dat_annot <- simulateH2Data(n_snps = 500, nBlocks = 5) - -test_that("lderUnivariate with annotations returns enrichment data.frame", { - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_true(is.data.frame(res$enrichment)) -}) - -test_that("lder enrichment has correct columns", { - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expected_cols <- c( - "annotation", - "tau", - "tauSe", - "enrichment", - "enrichmentSe", - "enrichmentP", - "propH2", - "propSnps" - ) - expect_true(all(expected_cols %in% colnames(res$enrichment))) -}) - -test_that("lder with annotations returns annotationJackknifeCoefs matrix", { - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_true(is.matrix(res$annotationJackknifeCoefs)) - # nBlocks rows (5 blocks in the annotation test data) - expect_equal(nrow(res$annotationJackknifeCoefs), 5L) -}) - -test_that("lder with annotations returns scoreStats list", { - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_type(res$scoreStats, "list") - expect_true(all(c("z", "R") %in% names(res$scoreStats))) -}) - -# ============================================================================= -# HDL annotation tests (h2Hdl.R stratified paths) -# ============================================================================= - -test_that("hdlUnivariate with annotations returns enrichment data.frame with correct columns", { - set.seed(123) - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_true(is.data.frame(res$enrichment)) - expected_cols <- c( - "annotation", - "tau", - "tauSe", - "enrichment", - "enrichmentSe", - "enrichmentP", - "propH2", - "propSnps" - ) - expect_true(all(expected_cols %in% colnames(res$enrichment))) - # Should have one row per baseline annotation - expect_equal(nrow(res$enrichment), 1L) # 1 baseline annotation - # Values should be finite - expect_true(all(is.finite(res$enrichment$tau))) - expect_true(all(is.finite(res$enrichment$enrichment))) -}) - -test_that("hdlUnivariate with annotations returns annotationJackknifeCoefs matrix", { - set.seed(124) - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_true(is.matrix(res$annotationJackknifeCoefs)) - # nBlocks rows (5 blocks in dat_annot) - expect_equal(nrow(res$annotationJackknifeCoefs), 5L) - # Number of columns matches baseline annotation count - expect_equal(ncol(res$annotationJackknifeCoefs), 1L) - # Values should be finite - expect_true(all(is.finite(res$annotationJackknifeCoefs))) -}) - -test_that("hdlUnivariate with annotations and local = TRUE returns local data.frame", { - set.seed(125) - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot, - local = TRUE - ) - expect_true(is.data.frame(res$local)) - expect_true("h2Local" %in% colnames(res$local)) - expect_true("h2LocalSe" %in% colnames(res$local)) - expect_true("blockId" %in% colnames(res$local)) - # Should have one row per block - expect_equal(nrow(res$local), 5L) -}) - -test_that("hdlUnivariate with annotations returns scoreStats with z and R", { - set.seed(126) - annot <- makeTestAnnotations(dat_annot$n_snps) - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_type(res$scoreStats, "list") - expect_true(all(c("z", "R") %in% names(res$scoreStats))) - # z should have length = number of candidate annotations (1) - expect_length(res$scoreStats$z, 1L) - expect_true(is.finite(res$scoreStats$z[1])) - # R should be a matrix - expect_true(is.matrix(res$scoreStats$R)) - expect_equal(dim(res$scoreStats$R), c(1L, 1L)) - # annotationNames should be present - expect_true("annotationNames" %in% names(res$scoreStats)) - expect_equal(res$scoreStats$annotationNames, "candidate1") -}) - -# ============================================================================= -# gLDSC annotation tests (h2Gldsc.R stratified paths) -# ============================================================================= - -# gLDSC annotation helper: use a spatially varying baseline instead of -# all-ones, because computeldscores with an all-ones baseline produces -# LD scores identical to the base L2 column, making the design matrix -# singular. A half-on/half-off baseline avoids collinearity. -makeGldscAnnotations <- function(n_snps) { - set.seed(77) - snp_gr <- GenomicRanges::GRanges( - seqnames = rep("chr1", n_snps), - ranges = IRanges::IRanges( - start = seq(50, by = 100, length.out = n_snps), - width = 1L - ) - ) - # Spatially structured baseline: first half = 1, second half = 0 - base_col <- as.numeric(seq_len(n_snps) <= n_snps / 2) - # Binary candidate: random 30% - cand_col <- rbinom(n_snps, 1, 0.3) - mat <- cbind(base_col, cand_col) - meta <- data.frame( - name = c("baseline1", "candidate1"), - tier = c("baseline", "candidate"), - type = c("binary", "binary"), - stringsAsFactors = FALSE - ) - AnnotationMatrix(mat, snp_gr, meta, genome = "hg19") -} - -test_that("gldscUnivariate with annotations returns enrichment data.frame", { - set.seed(200) - annot <- makeGldscAnnotations(dat_annot$n_snps) - res <- pecotmr:::gldscUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$ld_score_ref, - annotations = annot - ) - expect_true(is.data.frame(res$enrichment)) - expected_cols <- c( - "annotation", - "tau", - "tauSe", - "enrichment", - "enrichmentSe", - "enrichmentP", - "propH2", - "propSnps" - ) - expect_true(all(expected_cols %in% colnames(res$enrichment))) - # Should have one row per baseline annotation - expect_equal(nrow(res$enrichment), 1L) - # Values should be finite - expect_true(all(is.finite(res$enrichment$tau))) - expect_true(all(is.finite(res$enrichment$enrichment))) -}) - -test_that("gldscUnivariate with annotations returns annotationJackknifeCoefs matrix", { - set.seed(201) - annot <- makeGldscAnnotations(dat_annot$n_snps) - res <- pecotmr:::gldscUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$ld_score_ref, - annotations = annot - ) - expect_true(is.matrix(res$annotationJackknifeCoefs)) - # gldsc jackknife uses 200 blocks by default; with 500 SNPs the actual - # number of unique blocks equals ceil(500/ceil(500/200)) = 200 - expect_true(nrow(res$annotationJackknifeCoefs) > 0) - # Number of columns matches baseline annotation count - expect_equal(ncol(res$annotationJackknifeCoefs), 1L) - # Values should be finite (allow some NAs from edge blocks) - expect_true(any(is.finite(res$annotationJackknifeCoefs))) -}) - -test_that("gldscUnivariate with annotations returns scoreStats", { - set.seed(202) - annot <- makeGldscAnnotations(dat_annot$n_snps) - res <- pecotmr:::gldscUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$ld_score_ref, - annotations = annot - ) - expect_type(res$scoreStats, "list") - expect_true(all(c("z", "R") %in% names(res$scoreStats))) - # z should have length = number of candidate annotations (1) - expect_length(res$scoreStats$z, 1L) - expect_true(is.finite(res$scoreStats$z[1])) - # R should be a matrix - expect_true(is.matrix(res$scoreStats$R)) - expect_equal(dim(res$scoreStats$R), c(1L, 1L)) - # annotationNames should be present - expect_true("annotationNames" %in% names(res$scoreStats)) - expect_equal(res$scoreStats$annotationNames, "candidate1") -}) - -# =========================================================================== -# Coverage-gap tests (appended) -# -# Targets the specific uncovered branches in R/h2EstimationWrappers.R: -# 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. -# =========================================================================== - # Flexible annotation builder: one baseline column (all-ones or spatial # half-on/half-off) plus `nCand` random binary candidate columns. makeCoverageAnnot <- function( @@ -2013,130 +1404,208 @@ makeCoverageAnnot <- function( AnnotationMatrix(mat, snp_gr, meta, genome = "hg19") } -# --------------------------------------------------------------------------- -# checkGenomeBuild — unknown object type branch -# --------------------------------------------------------------------------- +# The three estimators, each with the reference it reads and the baseline +# its annotations take. An all-ones baseline makes the LDER and HDL +# eigenvalue-score column the eigenvalue itself; for g-LDSC it would repeat +# the base LD score column and leave the design singular, so g-LDSC takes a +# half-on/half-off baseline instead. +.h2Runs <- list( + lder = list( + fn = pecotmr:::lderUnivariate, + ref = "eigen_ref", + baseline = "ones" + ), + gldsc = list( + fn = pecotmr:::gldscUnivariate, + ref = "ld_score_ref", + baseline = "spatial" + ), + hdl = list( + fn = pecotmr:::hdlUnivariate, + ref = "eigen_ref", + baseline = "ones" + ) +) + +# Run `method` on the simulated data `d`, passing `...` to the estimator. +.h2Run <- function(method, d, ...) { + run <- .h2Runs[[method]] + run$fn(d$z, d$n, d[[run$ref]], ...) +} -test_that("checkGenomeBuild errors on an unrecognized object type", { - expect_error( - pecotmr:::checkGenomeBuild(list(genome = "hg19")), - "Unknown object type" +# Annotations over `d`'s variants for `method`, with `nCand` candidates. +.h2RunAnnot <- function(method, d, nCand) { + makeCoverageAnnot( + d$n_snps, + baseline = .h2Runs[[method]]$baseline, + nCand = nCand ) -}) +} -# --------------------------------------------------------------------------- -# .rmaMeta — length-mismatch error -# --------------------------------------------------------------------------- +# Pre-compute shared test data +dat <- simulateH2Data() +# Five blocks and 500 SNPs for the annotation tests, so that the stratified +# designs are not singular. +dat_annot <- simulateH2Data(n_snps = 500, nBlocks = 5) -test_that(".rmaMeta errors when means and ses differ in length", { - expect_error( - pecotmr:::.rmaMeta(c(1, 2), c(1, 2, 3)), - "must have the same length" - ) +# ============================================================================= +# Unstratified estimates +# ============================================================================= + +test_that("each univariate estimator returns a finite h2 and a positive SE", { + fields <- c( + "h2", + "h2Se", + "intercept", + "interceptSe", + "local", + "enrichment", + "annotationJackknifeCoefs", + "scoreStats" + ) + for (method in names(.h2Runs)) { + res <- .h2Run(method, dat) + expect_true(is.list(res), info = method) + expect_true(all(fields %in% names(res)), info = method) + expect_true(is.finite(res$h2), info = method) + expect_true(res$h2 > -0.5 && res$h2 < 1.0, info = method) + expect_true(is.finite(res$h2Se), info = method) + expect_true(res$h2Se > 0, info = method) + # Without annotations there is no enrichment to report. + expect_null(res$enrichment, info = method) + } }) -test_that("lderUnivariate with annotations and local = TRUE returns local h2", { - annot <- makeCoverageAnnot(dat_annot$n_snps, baseline = "ones", nCand = 1L) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot, - local = TRUE - ) - expect_true(is.data.frame(res$local)) - expect_true("h2Local" %in% colnames(res$local)) - expect_equal(nrow(res$local), 5L) +test_that("lderUnivariate intercept is near zero for well-calibrated data", { + # In LDER the intercept parameter a represents confounding deviation: + # the model is E[chi2Rot - 1] = n * h2/M * d + n * a + # so a ~ 0 when there is no confounding. + res <- pecotmr:::lderUnivariate(dat$z, dat$n, dat$eigen_ref) + expect_true(is.finite(res$intercept)) + expect_true(abs(res$intercept) < 0.01) }) +test_that("each univariate estimator with local = TRUE returns per-block h2", { + for (method in names(.h2Runs)) { + res <- .h2Run(method, dat, local = TRUE) + expect_true(is.data.frame(res$local), info = method) + expect_true( + all(c("blockId", "h2Local", "h2LocalSe") %in% colnames(res$local)), + info = method + ) + } +}) -# --------------------------------------------------------------------------- -# Stratified score helpers — multiple-candidate (cor) branch -# --------------------------------------------------------------------------- +# ============================================================================= +# Stratified estimates +# ============================================================================= -test_that("lderUnivariate with 2 candidates returns a 2x2 score correlation", { - annot <- makeCoverageAnnot(dat_annot$n_snps, baseline = "ones", nCand = 2L) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot +test_that("each univariate estimator reports enrichment and score statistics", { + expected_cols <- c( + "annotation", + "tau", + "tauSe", + "enrichment", + "enrichmentSe", + "enrichmentP", + "propH2", + "propSnps" ) - expect_length(res$scoreStats$z, 2L) - expect_equal(dim(res$scoreStats$R), c(2L, 2L)) + for (method in names(.h2Runs)) { + annot <- .h2RunAnnot(method, dat_annot, 1L) + res <- .h2Run(method, dat_annot, annotations = annot) + # One enrichment row per baseline annotation + expect_true(is.data.frame(res$enrichment), info = method) + expect_true( + all(expected_cols %in% colnames(res$enrichment)), + info = method + ) + expect_equal(nrow(res$enrichment), 1L, info = method) + expect_true(all(is.finite(res$enrichment$tau)), info = method) + expect_true(all(is.finite(res$enrichment$enrichment)), info = method) + # One jackknife row per LD block (5), one column per baseline + # annotation + jk <- res$annotationJackknifeCoefs + expect_true(is.matrix(jk), info = method) + expect_equal(dim(jk), c(5L, 1L), info = method) + expect_true(all(is.finite(jk)), info = method) + # One score z per candidate annotation + ss <- res$scoreStats + expect_true(is.list(ss), info = method) + expect_true(all(c("z", "R") %in% names(ss)), info = method) + expect_equal(length(ss$z), 1L, info = method) + expect_true(is.finite(ss$z[1]), info = method) + expect_true(is.matrix(ss$R), info = method) + expect_equal(dim(ss$R), c(1L, 1L), info = method) + expect_equal(ss$annotationNames, "cand1", info = method) + } }) -test_that("hdlUnivariate with 2 candidates returns a 2x2 score correlation", { - annot <- makeCoverageAnnot(dat_annot$n_snps, baseline = "ones", nCand = 2L) - suppressWarnings( - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot +test_that("each estimator with annotations and local = TRUE gives local h2", { + for (method in names(.h2Runs)) { + annot <- .h2RunAnnot(method, dat_annot, 1L) + res <- .h2Run(method, dat_annot, annotations = annot, local = TRUE) + expect_true(is.data.frame(res$local), info = method) + expect_true( + all(c("blockId", "h2Local", "h2LocalSe") %in% colnames(res$local)), + info = method ) - ) - expect_length(res$scoreStats$z, 2L) - expect_equal(dim(res$scoreStats$R), c(2L, 2L)) + # One row per block + expect_equal(nrow(res$local), 5L, info = method) + } }) -test_that("gldscUnivariate with 2 candidates returns a 2x2 score correlation", { - annot <- makeCoverageAnnot( - dat_annot$n_snps, - baseline = "spatial", - nCand = 2L - ) - res <- pecotmr:::gldscUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$ld_score_ref, - annotations = annot - ) - expect_length(res$scoreStats$z, 2L) - expect_equal(dim(res$scoreStats$R), c(2L, 2L)) +# --------------------------------------------------------------------------- +# Stratified score helpers — multiple-candidate (cor) branch +# --------------------------------------------------------------------------- + +test_that("each estimator with 2 candidates returns a 2x2 score correlation", { + for (method in names(.h2Runs)) { + annot <- .h2RunAnnot(method, dat_annot, 2L) + res <- .h2Run(method, dat_annot, annotations = annot) + expect_equal(length(res$scoreStats$z), 2L, info = method) + expect_equal(dim(res$scoreStats$R), c(2L, 2L), info = method) + } }) # --------------------------------------------------------------------------- # Stratified score helpers — no-candidate (NULL scoreStats) branch # --------------------------------------------------------------------------- -test_that("lderUnivariate with baseline-only annotations yields NULL scoreStats", { - annot <- makeCoverageAnnot(dat_annot$n_snps, baseline = "ones", nCand = 0L) - res <- pecotmr:::lderUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) - expect_null(res$scoreStats) +test_that("each estimator with baseline-only annotations has NULL scoreStats", { + for (method in names(.h2Runs)) { + annot <- .h2RunAnnot(method, dat_annot, 0L) + res <- .h2Run(method, dat_annot, annotations = annot) + expect_null(res$scoreStats, info = method) + } }) -test_that("hdlUnivariate with baseline-only annotations yields NULL scoreStats", { - annot <- makeCoverageAnnot(dat_annot$n_snps, baseline = "ones", nCand = 0L) - suppressWarnings( - res <- pecotmr:::hdlUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$eigen_ref, - annotations = annot - ) +# =========================================================================== +# Error branches and degenerate inputs: an unknown object type for the +# genome check, mismatched .rmaMeta lengths, and unnamed jackknife +# coefficients for h2EstimateToSldscTrait. +# =========================================================================== + +# --------------------------------------------------------------------------- +# checkGenomeBuild — unknown object type branch +# --------------------------------------------------------------------------- + +test_that("checkGenomeBuild errors on an unrecognized object type", { + expect_error( + pecotmr:::checkGenomeBuild(list(genome = "hg19")), + "Unknown object type" ) - expect_null(res$scoreStats) }) -test_that("gldscUnivariate with baseline-only annotations yields NULL scoreStats", { - annot <- makeCoverageAnnot( - dat_annot$n_snps, - baseline = "spatial", - nCand = 0L - ) - res <- pecotmr:::gldscUnivariate( - dat_annot$z, - dat_annot$n, - dat_annot$ld_score_ref, - annotations = annot +# --------------------------------------------------------------------------- +# .rmaMeta — length-mismatch error +# --------------------------------------------------------------------------- + +test_that(".rmaMeta errors when means and ses differ in length", { + expect_error( + pecotmr:::.rmaMeta(c(1, 2), c(1, 2, 3)), + "must have the same length" ) - expect_null(res$scoreStats) }) # --------------------------------------------------------------------------- @@ -2156,42 +1625,6 @@ test_that("h2EstimateToSldscTrait assigns category names to unnamed annotationJa expect_equal(result$nBlocks, 10L) }) -# --------------------------------------------------------------------------- -# estimateH2 dispatch — `study` required for a multi-study collection -# --------------------------------------------------------------------------- - -test_that("estimateH2 errors when study is omitted for a multi-study collection", { - eigen_ref <- makeTestEigenRef() - n_snps <- length(eigen_ref) - set.seed(321) - df <- data.frame( - SNP = names(eigen_ref), - CHR = sub( - "^chr", - "", - as.character(GenomicRanges::seqnames(eigen_ref)) - ), - BP = GenomicRanges::start(eigen_ref), - A1 = as.character(S4Vectors::mcols(eigen_ref)$A1), - A2 = as.character(S4Vectors::mcols(eigen_ref)$A2), - Z = rnorm(n_snps), - N = rep(50000, n_snps), - stringsAsFactors = FALSE - ) - gr <- .dfToGwasGr(df) - ss2 <- GwasSumStats( - studyName = c("studyA", "studyB"), - entry = list(gr, gr), - genome = "hg19", - ldReference = makeTestGwasGenotypeHandle(), - varY = NA_real_ - ) - expect_error( - estimateH2(ss2, eigen_ref, method = "lder"), - "is required when" - ) -}) - # =========================================================================== # Deterministic h2 recovery + regression tests (correctness validation) # @@ -2199,8 +1632,8 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" # a KNOWN heritability, using fixed seeds so every run is deterministic and # 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. +# pin the known-input -> known-output values. A behavioral test locks in the +# LDER inSample wiring. # =========================================================================== # AR(1) LD blocks + a chol-based per-block MVN simulator for the standard @@ -2289,13 +1722,17 @@ test_that("estimateH2 errors when study is omitted for a multi-study collection" AnnotationMatrix(mat, gr, meta, genome = "hg19") } +# The HDL recovery tests use 10 blocks rather than 30: HDL refits once per +# block for its jackknife, so its cost grows with the square of the block +# count, and on 10 blocks the mean estimate still lands well inside the +# tolerances. test_that("hdlUnivariate recovers a known h2 (deterministic, seed = 1)", { - d <- .h2RecoveryRefs() + d <- .h2RecoveryRefs(nBlocks = 10L) uni <- rep(0.4 / d$M, d$M) set.seed(1) ests <- replicate(30, hdlUnivariate(d$simZ(uni), d$N, d$eigenRef)$h2) expect_lt(abs(mean(ests) - 0.4), 0.05) # recovers true h2 = 0.4 - expect_equal(mean(ests), 0.405, tolerance = 0.04) # stored known output + expect_equal(mean(ests), 0.395, tolerance = 0.04) # stored known output }) test_that("lderUnivariate recovers a known h2 (deterministic, seed = 1)", { @@ -2317,12 +1754,12 @@ test_that("gldscUnivariate recovers a known h2 (deterministic, seed = 1)", { }) test_that("hdlUnivariate recovers partitioned h2 (block-separable annots)", { - d <- .h2RecoveryRefs() + d <- .h2RecoveryRefs(nBlocks = 10L) annot <- .h2RecoveryAnnot(d$M, d$M / 2) perSnp <- ifelse(seq_len(d$M) <= d$M / 2, 0.6 / d$M, 0.2 / d$M) M_a <- c(d$M / 2, d$M / 2) set.seed(1) - h2 <- rowMeans(replicate(20, { + h2 <- rowMeans(replicate(15, { r <- hdlUnivariate(d$simZ(perSnp), d$N, d$eigenRef, annotations = annot) r$enrichment$tau * M_a })) @@ -2347,24 +1784,6 @@ test_that("gldscUnivariate recovers enrichment direction (annotA > annotB)", { expect_lt(e[2], 0.8) # annotB depleted }) -test_that("HDL uses the finite-reference correction (nRef changes h2)", { - d <- .h2RecoveryRefs() - set.seed(1) - z <- d$simZ(rep(0.4 / d$M, d$M)) - refBig <- d$eigenRef - refSmall <- d$eigenRef - refSmall@nSamples <- 2000L - h2Big <- hdlUnivariate(z, d$N, refBig)$h2 - # nRef = 2000 against this N is exactly the regime where the - # finite-reference term dominates, so the fit lands on its bound and says - # so. That is the behaviour under test, not noise to be ignored. - expect_warning( - h2Small <- hdlUnivariate(z, d$N, refSmall)$h2, - "sits at the top of its range" - ) - expect_gt(abs(h2Big - h2Small), 0.05) -}) - test_that("LDER uses the in-sample vs out-of-sample weight switch", { d <- .h2RecoveryRefs() set.seed(1) @@ -2378,22 +1797,8 @@ test_that("LDER uses the in-sample vs out-of-sample weight switch", { ))) }) -test_that("gLDSC requires full LD matrices and gives a positive jackknife SE", { - noMat <- makeTestScoreRef(with_ld_matrices = FALSE) - ss <- makeTestSumstatsForRef(noMat) - expect_error( - estimateH2(ss, noMat, method = "gldsc"), - "g-LDSC needs each LD block's LD" - ) - d <- .h2RecoveryRefs() - set.seed(1) - res <- gldscUnivariate(d$simZ(rep(0.4 / d$M, d$M)), d$N, d$scoreRef) - expect_true(is.finite(res$h2Se)) - expect_gt(res$h2Se, 0) -}) - -# The two S-LDSC recovery checks live here rather than with the rest of the -# S-LDSC block because they need .h2RecoveryRefs(), defined just above. +# The S-LDSC checks below live here rather than with the rest of the S-LDSC +# block because they need .h2RecoveryRefs(), defined just above. # S-LDSC is a genome-scale method: real analyses regress over ~1M variants. # Every reference in this suite is a few thousand, and at that size the # intercept is not identifiable -- an unweighted OLS on the same data also @@ -2555,12 +1960,17 @@ test_that("S-LDSC recovers enrichment direction for one annotation", { e <- eigen(b$R, symmetric = TRUE) list(values = e$values, vectors = e$vectors, snpIdx = b$snpIdx) }) + # The frozen table holds the blocks 1-based, as they were always read. + ldBlocks <- GenomicRanges::GRanges( + fx$ldBlocks$chrom, + IRanges::IRanges(fx$ldBlocks$start, fx$ldBlocks$end) + ) list( score = LdScore( snpInfo = fx$snpInfo, ldScores = matrix(base, ncol = 1, dimnames = list(NULL, "base_l2")), ldScoreWeights = base, - ldBlocks = fx$ldBlocks, + ldBlocks = ldBlocks, nSamples = nSamples, genome = fx$genome, ldMatrixList = blocks @@ -2568,7 +1978,7 @@ test_that("S-LDSC recovers enrichment direction for one annotation", { eigen = LdEigen( snpInfo = fx$snpInfo, eigenList = eigens, - ldBlocks = fx$ldBlocks, + ldBlocks = ldBlocks, nSamples = nSamples, genome = fx$genome ) @@ -3114,3 +2524,36 @@ test_that("the DL fallback carries metaArgs too", { expect_equal(seen[[2]]$method, "DL") expect_true(all(map_dbl(seen, "level") == 90)) }) + +test_that("estimateH2 reads a study split across LD blocks as one study", { + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) + gr <- sumStats(ss) + mid <- GenomicRanges::start(gr)[[10L]] + split <- GwasSumStats( + studyName = "test", + entry = list(gr), + genome = "hg19", + ldReference = makeTestGwasGenotypeHandle(), + region = GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(gr))[[1L]], + IRanges::IRanges(c(1L, mid + 1L), c(mid, .Machine$integer.max)) + ) + ) + expect_equal(nrow(split), 2L) + expect_equal( + heritabilityEstimate(estimateH2(split, ref, method = "lder")), + heritabilityEstimate(estimateH2(ss, ref, method = "lder")) + ) + # Two studies still need one named. + two <- GwasSumStats( + studyName = c("a", "b"), + entry = list(gr, gr), + genome = "hg19", + ldReference = makeTestGwasGenotypeHandle() + ) + expect_error( + estimateH2(two, ref, method = "lder"), + "`studyName` is required when the GwasSumStats has 2 studies" + ) +}) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index cd1216f7..a3432f08 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -62,7 +62,7 @@ ... ) { vids <- colnames(dataX) - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(method = method, cond = conditionIdx), topLoci = data.frame( @@ -218,7 +218,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", samplePartition = sp, foldFits = list(fold_1 = fp, fold_2 = fp) ) - twEntry <- twasWeightsRow( + twEntry <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2), methodFits = fp, @@ -253,7 +253,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", verbose = 1, mvPrior = NULL, mvPriorCv = NULL, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), seed = NULL ) { captured <<- list( @@ -315,7 +315,7 @@ test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", ncol(Y), dimnames = list(colnames(X), colnames(Y)) ) - e <- twasWeightsRow( + e <- TwasWeightsRow( variantIds = colnames(X), weights = W, methodFits = .je_fakeMrmashFit() @@ -603,9 +603,10 @@ test_that("fitJointGroup(SumStats, Twas): real mr.mash-rss keys stat$n (regressi # errored in sqrt(nVec) on genuine summary-statistic input. This drives the # unmocked fitter end to end. set.seed(1) - p <- 30L + # Small enough that the real mr.mash.rss fit stays quick. + p <- 10L K <- 2L - nObs <- 400L + nObs <- 100L X <- matrix(rnorm(nObs * p), nObs, p) colnames(X) <- sprintf("chr1:%d:A:G", 100L * seq_len(p)) R <- cor(X) @@ -1074,10 +1075,9 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro }) # ---- SR-TWAS ensemble layer (.twasEnsembleLayer) ---------------------------- -# The ensemble orchestration formerly inside .twasWeightsPipelineMatrix is now a -# LAYER ON TOP of per-method fitting: per condition, read each method's retained -# out-of-fold CV predictions + weights + R^2, drop methods below the cutoff -# (needs >= 2), and stack via `ensembleWeights` per context. +# The ensemble is a LAYER ON TOP of per-method fitting: per condition, read each +# method's retained out-of-fold CV predictions + weights + R^2, drop methods +# below the cutoff (needs >= 2), and stack via `ensembleWeights` per context. .je_ensGroup <- function(n = 40L, nCond = 2L) { samp <- paste0("s", seq_len(n)) @@ -1112,7 +1112,7 @@ test_that(".runJointCell: composed/sumstats (context+trait vary) -> per-tuple ro pr <- predCor * Y[, r] + rnorm(nrow(Y), sd = 0.3) names(pr) <- rownames(Y) rsq <- stats::cor(Y[, r], pr)^2 - twasWeightsRow( + TwasWeightsRow( variantIds = vars, weights = rnorm(length(vars)), cvResult = list( @@ -1183,7 +1183,7 @@ test_that(".twasEnsembleLayer: < 2 methods pass the R^2 cutoff -> NULL (skip)", expect_true(all(map_lgl(ens, is.null))) }) -# ---- engine twas fitter: orchestration absorbed from .twasWeightsPipelineMatrix +# ---- engine twas fitter (fitJointGroup on a TwasJointPipeline) -------------- test_that("fitJointGroup(twas): leakage warning when a full-data mr.mash prior is reused across folds", { set.seed(3) @@ -1444,7 +1444,7 @@ test_that(".enumCrossContextIndividual: one group per trait in >= 2 contexts", { ) { if (tid == "G2") { return(NULL) - } # skip branch (461) + } # skip branch X <- matrix( 0, 4, @@ -1501,7 +1501,7 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex traits = list(S = "t1") ) local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromRef = .je_mockLd, .package = "pecotmr" @@ -1514,7 +1514,7 @@ test_that(".enumCrossContextSumstats: groups per (study, trait) with >= 2 contex test_that(".enumCrossContextSumstats: < 2 contexts and < 2 tuple rows skip", { local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromRef = .je_mockLd, .package = "pecotmr" @@ -1557,7 +1557,7 @@ test_that(".enumCrossTraitIndividual: one group per context with >= 2 traits + p ) { if (cx == "c2") { return(NULL) - } # skip branch (511) + } # skip branch X <- matrix( 0, 4, @@ -1604,7 +1604,7 @@ test_that(".enumCrossTraitSumstats: groups per (study, context) with >= 2 traits traits = list(S = c("t1", "t2")) ) local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromRef = .je_mockLd, .package = "pecotmr" @@ -1625,7 +1625,7 @@ test_that(".enumCrossStudySumstats: group per (context, trait) in >= 2 studies", traits = list(S1 = "t1", S2 = "t1") ) local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .buildJointSumstatZMatrix = .je_mockJointZ, .ldFromRef = .je_mockLd, .package = "pecotmr" @@ -1717,6 +1717,40 @@ test_that(".enumComposedIndividual: study not in scope / NULL xy -> empty", { ) # xy NULL }) +test_that(".enumTopPcIndividual enumerates only the studies in scope", { + # Reached through .jointDispatchTable, which covr cannot see, so called + # directly here. + data(qtlDatasetExample) + qd <- qtlDatasetExample + expect_identical( + pecotmr:::.enumTopPcIndividual(qd, list(studies = "other")), + list() + ) + seen <- list() + local_mocked_bindings( + .enumTopPcForContext = function( + cx, + data, + scope, + args, + studyName, + phenotypeFilter + ) { + seen[[cx]] <<- list(study = studyName, filter = phenotypeFilter) + list(cx) + }, + .package = "pecotmr" + ) + scope <- list(studies = "study1", contexts = list(study1 = c("a", "b"))) + expect_identical( + pecotmr:::.enumTopPcIndividual(qd, scope), + list("a", "b") + ) + expect_identical(seen$a$study, "study1") + # The joint engine's own phenotype QC when the run supplied none. + expect_identical(seen$a$filter$naAction, "drop") +}) + test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait)", { scope <- list( studies = "S", @@ -1726,12 +1760,12 @@ test_that(".enumUnivariateIndividual: one 1-condition group per (context, trait) samp <- paste0("s", 1:5) local_mocked_bindings( studyName = function(data) "S", - molecularTraits = function(data, contexts) .je_mkSe(c("G1", "G2")), + .qtlContextSe = function(data, context) .je_mkSe(c("G1", "G2")), .fmResidPheno = function( data, contexts, traitId, - naAction = "drop", + phenotypeFilter = NULL, ... ) { matrix(0, 5, 1, dimnames = list(samp, traitId)) @@ -1768,12 +1802,12 @@ test_that(".enumUnivariateIndividual: too few shared samples skips the tuple", { ) local_mocked_bindings( studyName = function(data) "S", - molecularTraits = function(data, contexts) .je_mkSe("G1"), + .qtlContextSe = function(data, context) .je_mkSe("G1"), .fmResidPheno = function( data, contexts, traitId, - naAction = "drop", + phenotypeFilter = NULL, ... ) { matrix(0, 1, 1, dimnames = list("s1", traitId)) @@ -1817,7 +1851,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { traits = list(S = "t1") ) local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(c(1L, 2L)), @@ -1841,7 +1875,7 @@ test_that(".enumComposedSumstats: one group per fixed-axis row block", { test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) NULL, .package = "pecotmr" ) @@ -1851,9 +1885,9 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { list(studies = "S") ), 0L - ) # gi NULL (646) + ) # gi NULL local_mocked_bindings( - ldReference = function(x) NULL, + .jointRowsLdRef = function(data, rows, label) NULL, .enumerateComposedSumstatGroups = function(spec, data, scope) { list( groups = list(1L), @@ -1873,7 +1907,7 @@ test_that(".enumComposedSumstats: NULL group index and singleton blocks skip", { args = list(axes = c("context", "trait")) ), 0L - ) # < 2 gIdx (649) + ) # < 2 gIdx }) # ============================================================================= @@ -2214,7 +2248,7 @@ test_that(".twasEnsembleLayer: entries lacking CV predictions are skipped", { g <- .je_ensGroup(nCond = 1L) good <- .je_ensEntries(g, 0.85) # A method whose entry carries no CV predictions -> contributes nothing. - noCv <- list(twasWeightsRow( + noCv <- list(TwasWeightsRow( variantIds = colnames(.jgX(g)), weights = rnorm(ncol(.jgX(g))), cvResult = NULL @@ -2322,9 +2356,9 @@ test_that(".jointTwasCvResult: NULL cv and empty/absent payloads degrade gracefu foldFits = list(fold_1 = list(other = 1)) ) out <- pecotmr:::.jointTwasCvResult(cv, "mrmash") - expect_null(out$predictions) # pickByBase empty (252) - expect_null(out$foldFits) # all-NULL ffKey (260) - # A method token absent from a non-empty prediction list -> NULL (255). + expect_null(out$predictions) # pickByBase empty + expect_null(out$foldFits) # all-NULL ffKey + # A method token absent from a non-empty prediction list -> NULL. cv2 <- list( samplePartition = NULL, prediction = list(lasso_predicted = matrix(0, 1, 1)), @@ -2412,7 +2446,7 @@ test_that(".twasGroupArgs: takes the CV partition from the fine-mapping CV when .package = "pecotmr" ) out <- pecotmr:::.twasGroupArgs(g, pipe, list(fineMappingResult = "FMR")) - expect_identical(out$samplePartition, sp) # line 692 + expect_identical(out$samplePartition, sp) }) test_that(".runJointCell: a token whose fitter returns NULL is skipped", { @@ -2422,7 +2456,7 @@ test_that(".runJointCell: a token whose fitter returns NULL is skipped", { fitJointGroup = function(...) NULL, .package = "pecotmr" ) - expect_null(pecotmr:::.runJointCell(cell, pipe, NULL, NULL, "mvsusie")) # 755 + expect_null(pecotmr:::.runJointCell(cell, pipe, NULL, NULL, "mvsusie")) }) test_that(".runJointSpecs: region mode without traitId restricts scoped traits to the locus", { @@ -2430,7 +2464,7 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 100)) captured <- NULL local_mocked_bindings( - # S2 has no scoped contexts -> the region-restriction loop skips it (873). + # S2 has no scoped contexts -> the region-restriction loop skips it. .fmResolveSpecScope = function(spec, data, contexts, traitIds) { list( studies = c("S", "S2"), @@ -2438,7 +2472,7 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t traits = list(S = c("g1", "g2"), S2 = "g9") ) }, - molecularTraits = function(data, contexts) .je_mkSe(c("g1", "g2")), + .qtlContextSe = function(data, context) .je_mkSe(c("g1", "g2")), .fmTraitsInRegion = function(se, traits, region) { captured <<- traits "g1" @@ -2457,7 +2491,7 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t args = list(region = region) ) expect_null(res) # empty cell -> NULL - expect_equal(captured, c("g1", "g2")) # 871-875 ran + expect_equal(captured, c("g1", "g2")) # the restriction ran }) @@ -2503,8 +2537,8 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t test_that("traitPos comes from the QtlSumStats traitPos column", { ss <- .je_ssWithTraitPos() - g1 <- pecotmr:::.traitPosFor(ss, "brain", "G1") - g2 <- pecotmr:::.traitPosFor(ss, "brain", "G2") + g1 <- pecotmr:::.traitPosFor(ss, "S", "brain", "G1") + g2 <- pecotmr:::.traitPosFor(ss, "S", "brain", "G2") expect_s4_class(g1, "GRanges") expect_equal(GenomicRanges::start(g1), 500L) expect_equal(GenomicRanges::start(g2), 900L) @@ -2514,37 +2548,72 @@ test_that("traitPos comes from the QtlSumStats traitPos column", { test_that("traitPos is NULL when the sumstats cannot supply one", { ss <- .je_ssWithTraitPos() - expect_null(pecotmr:::.traitPosFor(ss, "brain", "absentTrait")) - expect_null(pecotmr:::.traitPosFor(ss, "absentContext", "G1")) + expect_null(pecotmr:::.traitPosFor(ss, "S", "brain", "absentTrait")) + expect_null(pecotmr:::.traitPosFor(ss, "S", "absentContext", "G1")) + expect_null(pecotmr:::.traitPosFor(ss, "absentStudy", "brain", "G1")) # A collection with no traitPos column at all. data(qtlSumStatsExample) expect_false(is_in("traitPos", colnames(qtlSumStatsExample))) expect_null(pecotmr:::.traitPosFor( qtlSumStatsExample, + as.character(qtlSumStatsExample$study)[[1L]], as.character(qtlSumStatsExample$context)[[1L]], as.character(qtlSumStatsExample$trait)[[1L]] )) }) +test_that("each study keeps its own anchors for a shared (context, trait)", { + # Two studies carry brain:G1 at different positions and spans; a row + # named by its study gets that study's, not the first study's. + ss <- QtlSumStats( + studyName = c("S1", "S2"), + context = c("brain", "brain"), + trait = c("G1", "G1"), + entry = list( + .je_mkSsEntry("chr1", c(100L, 200L)), + .je_mkSsEntry("chr1", c(300L, 400L)) + ), + genome = "hg38", + traitPos = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(500L, 900L), width = 1L) + ) + ) + tp <- pecotmr:::.anchorVector( + ss, + c("S2", "S1"), + c("brain", "brain"), + c("G1", "G1"), + kind = "traitPos" + ) + expect_equal(GenomicRanges::start(tp), c(900L, 500L)) + rg <- pecotmr:::.fitRegionFor(ss, "S2", "brain", "G1") + expect_equal( + c(GenomicRanges::start(rg), GenomicRanges::end(rg)), + c(300L, 400L) + ) +}) + test_that("the fit region of a QtlSumStats row is its variant span", { # Sumstats carry no cis-window, so the fitted span IS the region -- # deliberately different from traitPos (500) above. ss <- .je_ssWithTraitPos() - r <- pecotmr:::.fitRegionFor(ss, "brain", "G1") + r <- pecotmr:::.fitRegionFor(ss, "S", "brain", "G1") expect_s4_class(r, "GRanges") expect_equal(GenomicRanges::start(r), 100L) expect_equal(GenomicRanges::end(r), 200L) - expect_null(pecotmr:::.fitRegionFor(ss, "brain", "absentTrait")) + expect_null(pecotmr:::.fitRegionFor(ss, "S", "brain", "absentTrait")) }) test_that("the fit region of a QtlDataset row is traitPos +/- the cis window", { data(qtlDatasetExample) qd <- qtlDatasetExample cx <- contexts(qd)[[1L]] - tr <- rownames(molecularTraits(qd, contexts = cx))[[1L]] - tp <- pecotmr:::.traitPosFor(qd, cx, tr) - bare <- pecotmr:::.fitRegionFor(qd, cx, tr) - wide <- pecotmr:::.fitRegionFor(qd, cx, tr, cisWindow = 1e5) + tr <- rownames(molecularTraits(qd, context = cx)[[cx]])[[1L]] + st <- studyName(qd) + tp <- pecotmr:::.traitPosFor(qd, st, cx, tr) + bare <- pecotmr:::.fitRegionFor(qd, st, cx, tr) + wide <- pecotmr:::.fitRegionFor(qd, st, cx, tr, cisWindow = 1e5) # With no window the region collapses onto the trait position. expect_equal(GenomicRanges::start(bare), GenomicRanges::start(tp)) # With one it is symmetric about it. @@ -2559,14 +2628,15 @@ test_that("the anchors are NULL for a trait the dataset does not carry", { data(qtlDatasetExample) qd <- qtlDatasetExample cx <- contexts(qd)[[1L]] - expect_null(pecotmr:::.traitPosFor(qd, cx, "absentTrait")) - expect_null(pecotmr:::.traitPosFor(qd, "absentContext", "anything")) - expect_null(pecotmr:::.fitRegionFor(qd, cx, "absentTrait")) + st <- studyName(qd) + expect_null(pecotmr:::.traitPosFor(qd, st, cx, "absentTrait")) + expect_null(pecotmr:::.traitPosFor(qd, st, "absentContext", "anything")) + expect_null(pecotmr:::.fitRegionFor(qd, st, cx, "absentTrait")) }) test_that("the anchors are NULL for an unsupported input class", { - expect_null(pecotmr:::.traitPosFor(42, "a", "b")) - expect_null(pecotmr:::.fitRegionFor(42, "a", "b")) + expect_null(pecotmr:::.traitPosFor(42, "s", "a", "b")) + expect_null(pecotmr:::.fitRegionFor(42, "s", "a", "b")) }) @@ -2588,7 +2658,7 @@ test_that("a sumstats entry with no variants has no fit region", { entry = list(emptyEntry), genome = "hg38" ) - expect_null(pecotmr:::.fitRegionFor(ss, "brain", "G0")) + expect_null(pecotmr:::.fitRegionFor(ss, "S", "brain", "G0")) }) test_that("slicing a CV result to one condition tolerates absent payloads", { @@ -2630,12 +2700,14 @@ test_that("the anchor vector keeps traitPos and region distinct", { ss <- .je_ssWithTraitPos() region <- pecotmr:::.anchorVector( ss, + c("S", "S"), c("brain", "brain"), c("G1", "G2"), kind = "region" ) anchors <- pecotmr:::.anchorVector( ss, + c("S", "S"), c("brain", "brain"), c("G1", "G2"), kind = "traitPos" @@ -2845,7 +2917,7 @@ test_that(".jointTwasCv prefers per-call CV settings over the config", { weightMethods, fitRetention, maxNumVariants, - numThreads, + BPPARAM, dataDrivenPriorMatricesCv, verbose, seed @@ -2913,8 +2985,14 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { ) local_mocked_bindings( studyName = function(data) "S1", - molecularTraits = function(data, contexts) phenotypes, - .fmResidPheno = function(data, contexts, traitId, naAction, ...) { + .qtlContextSe = function(data, context) phenotypes, + .fmResidPheno = function( + data, + contexts, + traitId, + phenotypeFilter, + ... + ) { matrix(1, 2L, 1L, dimnames = list(c("s1", "s2"), "t1")) }, .fmResidGeno = function( @@ -2942,11 +3020,11 @@ test_that(".enumUnivariateIndividual reads a region instead of a cis window", { pecotmr:::.enumUnivariateIndividual( NULL, scope, - list(region = "chr1:1-1000") + list(region = GenomicRanges::GRanges("chr1:1-1000")) ) # An explicit region replaces the trait-anchored cis window entirely -- # neither traitId nor cisWindow is passed down. - expect_equal(seen$region, "chr1:1-1000") + expect_equal(seen$region, GenomicRanges::GRanges("chr1:1-1000")) expect_null(seen$cisWindow) expect_null(seen$traitId) }) @@ -3158,7 +3236,7 @@ test_that(".twasEnsembleCollect answers empty parts when no token contributes", expect_identical(out$rsq, c()) }) -test_that(".jointAfForGroup resolves allele frequencies for an individual group", { +test_that(".jointAfForGroup is NULL without a QtlDataset or individual group", { data(qtlDatasetExample) X <- matrix( c(0, 1, 2, 1, 2, 0), @@ -3173,7 +3251,8 @@ test_that(".jointAfForGroup resolves allele frequencies for an individual group" ) # Not a QtlDataset -> no af rather than an error. expect_null(.jointAfForGroup(NULL, g)) - # A SumStats group has no design matrix to take frequencies from. + # Anything but an individual group has no design matrix to read + # frequencies from. expect_null(.jointAfForGroup(qtlDatasetExample, "not a group")) }) @@ -3242,7 +3321,6 @@ test_that(".jointMrmashRssWeights passes the caller's mr.mash options", { coverage = 0.95, crossValidationParam = list( folds = 2, - numThreads = 1, fitFullData = FALSE ) ) @@ -3363,3 +3441,73 @@ test_that(".jointGroupSelect drops pairs a per-context traitId leaves out", { list(A = list(brain = "g2", liver = "g2")) )) }) + +# =========================================================================== +# A summary-statistics joint group reads one LD matrix +# =========================================================================== + +# Two QtlSumStats rows (contexts c1, c2 of one study and trait) over the same +# five variants, each on the LD reference given for it. +.je_twoRowSs <- function(refs) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:5), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = seq_len(5) / 10, + N = 100L + ) + QtlSumStats( + studyName = c("S", "S"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + entry = list(gr, gr), + genome = "hg19", + ldReference = refs, + qcOptions = list(step1 = "ok") + ) +} + +# An LdMatrix over those five variants. +.je_ldm <- function(rho) { + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) + LdMatrix(`dimnames<-`(rho^abs(outer(1:5, 1:5, "-")), list(ids, ids))) +} + +test_that(".jointRowsLdRef returns the reference a group's rows share", { + ldm <- .je_ldm(0.2) + expect_identical( + pecotmr:::.jointRowsLdRef(.je_twoRowSs(ldm), 1:2, "probe"), + ldm + ) +}) + +test_that(".jointRowsLdRef refuses rows on different references", { + # A joint fit reads one LD matrix for every condition, so fitting these + # together would put one row against LD it was never harmonized to. + ss <- .je_twoRowSs(list(.je_ldm(0.2), .je_ldm(0.6))) + expect_error( + pecotmr:::.jointRowsLdRef(ss, 1:2, "probe"), + "probe: a joint fit uses one LD matrix" + ) + expect_error( + pecotmr:::.jointRowsLdRef(ss, 1:2, "probe"), + "S:c1:t1 -> ld1; S:c2:t1 -> ld2" + ) +}) + +test_that("a cross-context sumstats group refuses rows on two references", { + ss <- .je_twoRowSs(list(.je_ldm(0.2), .je_ldm(0.6))) + scope <- list( + studies = "S", + contexts = list(S = c("c1", "c2")), + traits = list(S = "t1") + ) + expect_error( + pecotmr:::.enumCrossContextSumstats(ss, scope), + "jointCrossContext \\(QtlSumStats\\): a joint fit uses one LD" + ) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index e8886dd2..c1623eb9 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -12,7 +12,7 @@ format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -105,6 +105,10 @@ ) } +# The default dataset, built on first use and shared by the parser tests +# that only read its names. +delayedAssign(".jsQd", .js_makeQtlDataset()) + # ----------------------------------------------------------------------------- # Scope helpers # ----------------------------------------------------------------------------- @@ -156,12 +160,13 @@ test_that(".sp* helpers: MultiStudyQtlDataset combines individual + sumstats", { # ----------------------------------------------------------------------------- test_that("parseJointSpecification: NULL returns empty list", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_equal(pecotmr:::parseJointSpecification(NULL, qd), list()) + expect_silent(pecotmr:::parseJointSpecification(NULL, qd)) }) test_that("parseJointSpecification: auto-wraps a single char vector", { - qd <- .js_makeQtlDataset() + qd <- .jsQd out <- pecotmr:::parseJointSpecification("context", qd) expect_equal(length(out), 1L) expect_equal(out[[1L]]$axes, "context") @@ -169,7 +174,7 @@ test_that("parseJointSpecification: auto-wraps a single char vector", { }) test_that("parseJointSpecification: accepts a list of specs", { - qd <- .js_makeQtlDataset() + qd <- .jsQd out <- pecotmr:::parseJointSpecification( list("context", c("context", "trait")), qd @@ -190,7 +195,7 @@ test_that("parseJointSpecification: accepts scope-restricted spec", { }) test_that("parseJointSpecification: rejects unknown axes", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_error( pecotmr:::parseJointSpecification(c("context", "bogus"), qd), "unknown axes" @@ -198,7 +203,7 @@ test_that("parseJointSpecification: rejects unknown axes", { }) test_that("parseJointSpecification: rejects duplicate axes", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_error( pecotmr:::parseJointSpecification(c("context", "context"), qd), "duplicate axes" @@ -206,7 +211,7 @@ test_that("parseJointSpecification: rejects duplicate axes", { }) test_that("parseJointSpecification: rejects unknown scope keys", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_error( pecotmr:::parseJointSpecification( list(list(axes = "context", scope = list(bogus = "x"))), @@ -228,7 +233,7 @@ test_that("parseJointSpecification: rejects scope values absent from data", { }) test_that("parseJointSpecification: rejects unknown spec elements", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_error( pecotmr:::parseJointSpecification( list(list(axes = "context", scope = NULL, bogus = "x")), @@ -243,7 +248,7 @@ test_that("parseJointSpecification: rejects unknown spec elements", { # ----------------------------------------------------------------------------- test_that("parseContexts: NULL passes through", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_null(pecotmr:::parseContexts(NULL, qd)) }) @@ -289,7 +294,7 @@ test_that("parseContexts: list form fills unmentioned studies with defaults", { # ----------------------------------------------------------------------------- test_that("parseTraitIds: NULL passes through", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_null(pecotmr:::parseTraitIds(NULL, qd)) }) @@ -333,28 +338,6 @@ test_that("parseTraitIds: doubly-nested study->context validates per context", { # 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 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. - qd <- .js_makeQtlDataset( - studyName = "A", - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - expect_error( - fineMappingPipeline( - qd, - methods = "mvsusie", - cisWindow = 1000L, - jointSpecification = "trait" - ), - "File does not exist" - ) -}) - test_that("fineMappingPipeline(QtlDataset): composed joint dispatcher is wired", { # Composed dispatcher accepts axes = c("context", "trait") for individual- # level input. On the fake fixture the genotype I/O fails when the @@ -410,17 +393,6 @@ 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" - ) - expect_silent( - pecotmr:::parseJointSpecification(NULL, qd) - ) -}) - test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit", { qd <- .js_makeQtlDataset(studyName = "A") expect_error( @@ -434,23 +406,6 @@ test_that("fineMappingPipeline(QtlDataset): invalid jointSpec errors before fit" ) }) -test_that("twasWeightsPipeline(QtlDataset): cross-trait joint dispatcher is wired", { - qd <- .js_makeQtlDataset( - studyName = "A", - contexts = "brain", - traits = c("ENSG_A", "ENSG_B") - ) - expect_error( - twasWeightsPipeline( - qd, - methods = "mrmash", - cisWindow = 1000L, - jointSpecification = "trait" - ), - "File does not exist" - ) -}) - test_that("twasWeightsPipeline(QtlDataset): study-axis on individual data errors", { qd <- .js_makeQtlDataset( studyName = "A", @@ -468,32 +423,11 @@ test_that("twasWeightsPipeline(QtlDataset): study-axis on individual data errors ) }) -test_that("twasWeightsPipeline(QtlSumStats): non-NULL jointSpec errors", { - ss <- .js_makeQtlSumStats( - studies = c("X", "Y"), - contexts = "DLPFC", - traits = "ENSG_A" - ) - # qcInfo is empty; the QC assertion fires BEFORE jointSpec parsing. - expect_error( - twasWeightsPipeline( - ss, - methods = "susie", - jointSpecification = "context" - ), - "QC" - ) -}) - -test_that("twasWeightsPipeline(MultiStudyQtlDataset): method exists", { - expect_true(existsMethod("twasWeightsPipeline", "MultiStudyQtlDataset")) -}) - # ============================================================================ # Joint dispatchers (merged from former tests/testthat/test_jointDispatchers.R) # ============================================================================ -context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") +context("joint dispatchers (fineMappingPipeline / twasWeightsPipeline)") # ============================================================================ # Strategy: each joint-dispatcher function is exercised by driving @@ -514,7 +448,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -601,7 +535,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") entry = map(seq_len(nrow(rows)), function(.) makeGr()), genome = "hg19", ldReference = .jd_makeHandle(), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) } @@ -653,7 +587,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") if (is.null(vids)) { vids <- "chr1:1200:A:G" } - fineMappingRow( + FineMappingRow( variantIds = vids, susieFit = list(method = method, payload = fit), topLoci = data.frame( @@ -695,7 +629,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") } # ============================================================================= -# fineMappingDispatcher: QtlSumStats +# fineMappingPipeline joint dispatch: QtlSumStats # ============================================================================= test_that("fineMappingPipeline(QtlSumStats): jointSpec='context' fits one joint per (study, trait)", { @@ -871,7 +805,7 @@ test_that("fineMappingPipeline(QtlSumStats): composed jointSpec rejects fsusie", }) # ============================================================================= -# twasDispatcher: QtlDataset +# twasWeightsPipeline joint dispatch: QtlDataset # ============================================================================= .jd_makeSe <- function(traits = c("t1", "t2"), n_samples = 30L, starts = NULL) { @@ -993,23 +927,6 @@ test_that("twasWeightsPipeline(QtlDataset): jointSpec='trait' fits mr.mash per c expect_true("jointTraits" %in% pecotmr:::.tupleColumnNames(res)) }) -test_that("twasWeightsPipeline(QtlDataset): study-axis fails on individual data", { - qd <- .jd_makeQtlDataset( - studyName = "Q1", - contexts = c("c1", "c2"), - traits = "t1" - ) - expect_error( - twasWeightsPipeline( - qd, - methods = "mrmash", - cisWindow = 1000L, - jointSpecification = "study" - ), - "requires sumstats input" - ) -}) - test_that("twasWeightsPipeline(QtlDataset): composed jointSpec axes=c('context','trait') fits", { qd <- .jd_makeQtlDataset( studyName = "Q1", @@ -1053,7 +970,7 @@ test_that("twasWeightsPipeline(QtlDataset): composed jointSpec including 'study' }) # ============================================================================= -# twasDispatcher: QtlSumStats +# twasWeightsPipeline joint dispatch: QtlSumStats # ============================================================================= test_that("twasWeightsPipeline(QtlSumStats): jointSpec='context' fits mr.mash.rss per (study, trait)", { @@ -1240,7 +1157,7 @@ test_that(".sp* helpers: unsupported class raises a labelled error", { # ----------------------------------------------------------------------------- test_that("parseJointSpecification: malformed inputs error", { - qd <- .js_makeQtlDataset() + qd <- .jsQd expect_error(pecotmr:::parseJointSpecification(42, qd), "must be NULL") expect_error( pecotmr:::parseJointSpecification(list(list(scope = NULL)), qd), @@ -1282,7 +1199,7 @@ test_that("parseContexts: malformed inputs error", { "non-empty character vector" ) expect_error(pecotmr:::parseContexts(list("brain"), qd), "named list") # unnamed - expect_error(pecotmr:::parseContexts(42, qd), "must be NULL") + expect_error(pecotmr:::parseContexts(42, qd), "`contexts` must be NULL") }) test_that("parseContexts: vector form refuses a context no study has", { @@ -1302,7 +1219,7 @@ test_that("parseTraitIds: malformed inputs error", { traits = c("ENSG1", "ENSG2") ) expect_error(pecotmr:::parseTraitIds(character(0), qd), "non-empty") - expect_error(pecotmr:::parseTraitIds(42, qd), "must be NULL") + expect_error(pecotmr:::parseTraitIds(42, qd), "`traitId` must be NULL") expect_error(pecotmr:::parseTraitIds(list("ENSG1"), qd), "named by study") expect_error( pecotmr:::parseTraitIds(list(nope = "ENSG1"), qd), @@ -1449,6 +1366,57 @@ test_that(".sumStatsRowsSelected applies study and per-context selections", { ) }) +test_that("a study's selected traits follow traitId, else region", { + # .js_makeSe places ENSG1 at chr1:100-149 and ENSG2 at chr1:200-249. + qd <- .js_makeQtlDataset(studyName = "A") + sel <- function(cx, traitId = NULL, region = NULL) { + pecotmr:::.contextSelectedTraits(cx, qd, traitId, region) + } + expect_equal(sel("brain"), c("ENSG1", "ENSG2")) + expect_equal(sel("brain", traitId = c("ENSG2", "ENSG9")), "ENSG2") + # A selection that leaves the context out keeps all of its traits. + expect_equal( + sel("liver", traitId = list(A = list(brain = "ENSG1"))), + c("ENSG1", "ENSG2") + ) + # region picks traits only when no trait was named at all. + nearEnsg1 <- GenomicRanges::GRanges("chr1:120-130") + expect_equal(sel("brain", region = nearEnsg1), "ENSG1") + expect_equal(sel("brain", traitId = "ENSG2", region = nearEnsg1), "ENSG2") + has <- function(contexts = NULL, traitId = NULL, region = NULL) { + pecotmr:::.studyHasSelectedTraits(qd, contexts, traitId, region) + } + expect_true(has(traitId = "ENSG1")) + expect_false(has(traitId = "ENSG9")) + expect_false(has(region = GenomicRanges::GRanges("chr1:5000-6000"))) + # None of the study's contexts selected leaves it no trait either. + expect_false(has(contexts = list(A = character(0)))) + expect_true(has(contexts = list(A = "liver"), traitId = "ENSG2")) +}) + +test_that("a multi-study run is refused only when no component has a trait", { + msqd <- MultiStudyQtlDataset( + qtlDatasets = list(A = .js_makeQtlDataset(studyName = "A")), + sumStats = .js_makeQtlSumStats(studies = "ssA") + ) + check <- function(traitId) { + pecotmr:::.msAssertTraitsSelected( + msqd, + list(contexts = NULL, traitId = traitId, region = NULL), + "aPipeline" + ) + } + # A trait the individual-level study carries, or one only the summary + # statistics carry: either is enough. + expect_silent(check("ENSG1")) + expect_silent(check("ENSG3")) + expect_error( + check("ENSG9"), + "aPipeline(MultiStudyQtlDataset): no traits selected.", + fixed = TRUE + ) +}) + # ----------------------------------------------------------------------------- # .buildJointSumstatZMatrix: SNP-order mismatch error # ----------------------------------------------------------------------------- @@ -1462,7 +1430,7 @@ test_that(".buildJointSumstatZMatrix: a mismatched SNP order across entries erro ) calls <- 0L local_mocked_bindings( - as.data.frame = function(x, studyName, context, trait, require, ...) { + .sumStatsDf = function(x, studyName, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") @@ -1497,7 +1465,7 @@ test_that(".buildIndividualCrossContextXy: skips when a trait spans < 2 contexts se1 <- .js_makeSe(traits = "g1") # g1 present se0 <- .js_makeSe(traits = "other") # g1 absent local_mocked_bindings( - molecularTraits = function(data, contexts) { + .qtlContextSe = function(data, context) { if (identical(contexts, "c1")) se1 else se0 }, .package = "pecotmr" @@ -1517,7 +1485,7 @@ test_that(".buildIndividualCrossContextXy: region path + complete-case skip", { samp <- paste0("s", 1:6) region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 10000)) local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -1556,7 +1524,7 @@ test_that(".buildIndividualCrossContextXy: region path + complete-case skip", { test_that(".buildIndividualCrossContextXy: too few shared samples skips", { se <- .js_makeSe(traits = "g1", samples = paste0("s", 1:6)) local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -1590,10 +1558,15 @@ test_that(".buildIndividualCrossContextXy: too few shared samples skips", { ))) }) -test_that(".fmTraitsInRegion: filters traits by phenotype overlap with the region", { +test_that(".fmTraitsInRegion keeps overlapping traits; NULL keeps all", { se <- .js_makeSe(traits = c("g1", "g2")) # g1@~100, g2@~200 region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(90, 160)) expect_equal(pecotmr:::.fmTraitsInRegion(se, c("g1", "g2"), region), "g1") + both <- GenomicRanges::GRanges("chr1", IRanges::IRanges(90, 260)) + expect_setequal( + pecotmr:::.fmTraitsInRegion(se, c("g1", "g2"), both), + c("g1", "g2") + ) expect_equal( pecotmr:::.fmTraitsInRegion(se, c("g1", "g2"), NULL), c("g1", "g2") @@ -1605,7 +1578,7 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp samp <- paste0("s", 1:6) # < 2 scoped traits in the context -> NULL. local_mocked_bindings( - molecularTraits = function(data, contexts) se2, + .qtlContextSe = function(data, context) se2, .package = "pecotmr" ) expect_null(suppressMessages(pecotmr:::.buildIndividualCrossTraitXy( @@ -1619,7 +1592,7 @@ test_that(".buildIndividualCrossTraitXy: skip branches (< 2 traits, region, comp ))) # region path + < 2 complete cases. local_mocked_bindings( - molecularTraits = function(data, contexts) se2, + .qtlContextSe = function(data, context) se2, .fmResidGeno = function( x, contexts, @@ -1659,7 +1632,7 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { scope <- list(contexts = list(S = "c1"), traits = list(S = c("g1", "g2"))) # Single context: YresList wrap branch, then a valid 2-tuple build. local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -1693,7 +1666,7 @@ test_that(".buildComposedIndividualXy: skip branches and single-context wrap", { # < 2 tuples -> NULL. scope1 <- list(contexts = list(S = "c1"), traits = list(S = "g1")) local_mocked_bindings( - molecularTraits = function(data, contexts) { + .qtlContextSe = function(data, context) { .js_makeSe(traits = "g1") }, .package = "pecotmr" @@ -1754,7 +1727,7 @@ test_that(".fmSynthesizeJointSpec: trait wins over context; single/single -> emp # ----------------------------------------------------------------------------- .js_fmEntry <- function(vid = "chr1:100:A:G") { - fineMappingRow( + FineMappingRow( variantIds = vid, susieFit = list(), topLoci = data.frame( @@ -1800,7 +1773,7 @@ test_that(".twasMergeResultsByKey: merges per-region TwasWeights entries", { context = "c1", trait = "t1", method = "lasso", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.5 )) @@ -1842,8 +1815,8 @@ test_that(".twasDispatchJointSpecsQtlDataset: two region blocks are merged by ke trait = c("t1", "t1"), method = c("mrmash", "mrmash"), entry = list( - twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5), - twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) + TwasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5), + TwasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) ) ) } @@ -1963,7 +1936,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r context = "c1", trait = "t1", method = "mrmash", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.5 )) @@ -1973,7 +1946,7 @@ test_that(".twasDispatchJointSpecsMultiStudy: routes components + sumstats and r context = "c1", trait = "t1", method = "mrmash", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.5 )), @@ -2020,8 +1993,8 @@ test_that(".twasDispatchJointSpecsMultiStudy: study spec, no sumStats -> message }) # ============================================================================ -# Mop-up: remaining .sp* empties, parseContexts unnamed list, validate no-op, -# X/Y builder skip paths, region-missing keys in merges, FM multi-region merge. +# Mop-up: remaining .sp* empties, X/Y builder skip paths, region-missing keys +# in merges, FM multi-region merge. # ============================================================================ test_that(".sp* QtlDataset: mismatched study / absent context return empty", { @@ -2030,15 +2003,15 @@ test_that(".sp* QtlDataset: mismatched study / absent context return empty", { contexts = "brain", traits = c("g1", "g2") ) - expect_equal(pecotmr:::.spListContexts(qd, "wrong"), character(0)) # 59 - expect_equal(pecotmr:::.spListTraits(qd, studyName = "wrong"), character(0)) # 93 - expect_equal(pecotmr:::.spListTraits(qd, context = "nope"), character(0)) # 98 + expect_equal(pecotmr:::.spListContexts(qd, "wrong"), character(0)) + expect_equal(pecotmr:::.spListTraits(qd, studyName = "wrong"), character(0)) + expect_equal(pecotmr:::.spListTraits(qd, context = "nope"), character(0)) }) 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( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -2067,7 +2040,7 @@ test_that(".buildIndividualCrossTraitXy: disjoint X/Y samples skip the context", verbose = 1, label = "X", studyName = "S" - ))) # 730 + ))) }) test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA rows skip", { @@ -2077,9 +2050,9 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA contexts = list(S = c("c1", "c2")), traits = list(S = c("g1", "g2")) ) - # (a) disjoint X samples -> < 2 common -> NULL (774). + # (a) disjoint X samples -> < 2 common -> NULL. local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -2117,10 +2090,10 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA cisWindow = 1000L, verbose = 1, label = "X" - ))) # 774 - # (b) one context's Y lacks the trait column -> tuple skipped -> < 2 yCols (779/785). + ))) + # (b) one context's Y lacks the trait column -> tuple skipped -> < 2 yCols. local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -2151,10 +2124,10 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA cisWindow = 1000L, verbose = 1, label = "X" - ))) # 779/785 - # (c) two valid columns but < 2 complete rows (NA) -> NULL (788). + ))) + # (c) two valid columns but < 2 complete rows (NA) -> NULL. local_mocked_bindings( - molecularTraits = function(data, contexts) se, + .qtlContextSe = function(data, context) se, .fmResidGeno = function( x, contexts, @@ -2195,7 +2168,7 @@ test_that(".buildComposedIndividualXy: disjoint samples / missing trait col / NA cisWindow = 1000L, verbose = 1, label = "X" - ))) # 788 + ))) }) test_that(".fmMergeResultsByKey: a key missing from a later region contributes nothing", { @@ -2223,7 +2196,7 @@ test_that(".fmMergeResultsByKey: a key missing from a later region contributes n ) out <- pecotmr:::.fmMergeResultsByKey(list(twoRow, oneRow)) expect_equal(nrow(out), 2L) - expect_equal(seen, 3L) # 2 for c1 row + 1 for c2 row (849 else) + expect_equal(seen, 3L) # 2 for c1 row + 1 for c2 row }) test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { @@ -2258,7 +2231,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: two region blocks are merged", { list(data = qd, verbose = 0, xRegions = list(r1, r2)) ) expect_s4_class(res, "QtlFineMappingResult") - expect_equal(nrow(res), 2L) # 907-910 + expect_equal(nrow(res), 2L) # the two region blocks merged by key }) test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; all-NULL -> NULL", { @@ -2284,7 +2257,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al list(), list(data = qd, verbose = 0, cisWindow = 1000L, xRegions = list(NULL)) ) - expect_identical(out, res1) # length-1 short-circuit (909) + expect_identical(out, res1) # length-1 short-circuit local_mocked_bindings( .fmDispatchJointSpecRegion = function(...) NULL, .package = "pecotmr" @@ -2294,7 +2267,7 @@ test_that(".fmDispatchJointSpecsQtlDataset: a single region returns directly; al "mvsusie", list(), list(data = qd, verbose = 0, cisWindow = 1000L, xRegions = list(NULL)) - )) # all-NULL (908) + )) # all-NULL }) test_that(".twasMergeResultsByKey: a key absent from a later region contributes nothing", { @@ -2304,8 +2277,8 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes trait = c("t1", "t1"), method = c("lasso", "lasso"), entry = list( - twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.1), - twasWeightsRow(variantIds = "chr1:200:A:G", weights = 0.2) + TwasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.1), + TwasWeightsRow(variantIds = "chr1:200:A:G", weights = 0.2) ) ) oneRow <- TwasWeights( @@ -2313,13 +2286,13 @@ test_that(".twasMergeResultsByKey: a key absent from a later region contributes context = "c1", trait = "t1", method = "lasso", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.1 )) ) out <- pecotmr:::.twasMergeResultsByKey(list(twoRow, oneRow), c("rA", "rB")) - expect_equal(nrow(out), 2L) # 1063 else-branch + expect_equal(nrow(out), 2L) # c2 kept from the first region }) test_that(".twasMergedEntryAt concatenates one key's entry across regions", { @@ -2363,6 +2336,8 @@ test_that(".mergeEntryForKey gives NULL for a region lacking the tuple", { summaryStatsQc(qtlSumStatsMulticontextExample) )) } +# Built once on first use: summaryStatsQc() dominates these tests. +delayedAssign(".bjzSs", .bjz_qcd()) # @noRd .bjz_build <- function(ss, ...) { @@ -2371,20 +2346,20 @@ test_that(".mergeEntryForKey gives NULL for a region lacking the tuple", { seq_len(nrow(ss)), as.character(ss$context), "probe", - ldReference = ldReference(ss), + ldReference = ldReference(ss)[[1L]], cutoffs = .panelCutoffs(PanelFilterParam(...)) )) } test_that(".buildJointSumstatZMatrix filters nothing by default", { - ss <- .bjz_qcd() + ss <- .bjzSs jz <- .bjz_build(ss) expect_equal(length(jz$variantIds), sum(lengths(ss)) / nrow(ss)) expect_equal(ncol(jz$Z), nrow(ss)) }) test_that(".buildJointSumstatZMatrix drops panel-rare variants", { - ss <- .bjz_qcd() + ss <- .bjzSs full <- .bjz_build(ss) tight <- .bjz_build(ss, mafCutoff = 0.2) expect_lt(length(tight$variantIds), length(full$variantIds)) @@ -2395,13 +2370,13 @@ test_that(".buildJointSumstatZMatrix drops panel-rare variants", { }) test_that(".buildJointSumstatZMatrix agrees with .panelVariantFilter", { - ss <- .bjz_qcd() + ss <- .bjzSs ids <- .bjz_build(ss)$variantIds for (cut in c(0.05, 0.2)) { expect_equal( length(.bjz_build(ss, mafCutoff = cut)$variantIds), length(.panelVariantFilter( - ldReference(ss), + ldReference(ss)[[1L]], ids, PanelFilterParam(mafCutoff = cut) )), @@ -2414,7 +2389,7 @@ test_that(".buildJointSumstatZMatrix keeps Z aligned to its ids", { # Each context's own frame is narrowed to the filtered set before the # shared-SNP-order check; otherwise that check fires on a length mismatch # the filter itself created. - ss <- .bjz_qcd() + ss <- .bjzSs full <- .bjz_build(ss) tight <- .bjz_build(ss, mafCutoff = 0.2) expect_equal(rownames(tight$Z), tight$variantIds) @@ -2424,7 +2399,7 @@ test_that(".buildJointSumstatZMatrix keeps Z aligned to its ids", { }) test_that(".buildJointSumstatZMatrix honours a missingness cutoff", { - ss <- .bjz_qcd() + ss <- .bjzSs expect_lt( length(.bjz_build(ss, imissCutoff = 0)$variantIds), length(.bjz_build(ss)$variantIds) @@ -2439,3 +2414,78 @@ test_that(".msFoldStudyResults answers NULL when every fold is empty", { expect_null(pecotmr:::.msFoldStudyResults(list(), NULL)) expect_null(pecotmr:::.msFoldStudyResults(list(NULL, NULL), NULL)) }) + +test_that("the joint builders read phenotypes under the run's phenotype QC", { + # The cross-context, cross-trait and composed assemblies each read their + # phenotypes through .fmResidPheno(); the run's resolved filter has to + # reach it, or a joint fit would ignore the QC every other fit applies. + seen <- list() + samp <- c("s1", "s2", "s3") + se <- SummarizedExperiment::SummarizedExperiment( + assays = list(e = matrix(0, 2, 3, dimnames = list(c("t1", "t2"), samp))) + ) + local_mocked_bindings( + .crossContextPerTrait = function(...) c("c1", "c2"), + .crossTraitTooFew = function(...) FALSE, + .qtlContextSe = function(data, context) se, + .buildResidGeno = function(...) { + matrix(0, 3, 1, dimnames = list(samp, "v1")) + }, + .fmResidPheno = function( + data, + contexts, + traitId, + phenotypeFilter, + ... + ) { + seen[[length(seen) + 1L]] <<- phenotypeFilter + NULL + }, + .crossContextAssemble = function(...) "cc", + .crossTraitAssemble = function(...) "ct", + .package = "pecotmr" + ) + pf <- list(naAction = "impute", outlierAction = "drop") + common <- list( + residualizationParam = ResidualizationParam(), + genotypeFilter = pecotmr:::.qtlResolveFilter(), + phenotypeFilter = pf + ) + pecotmr:::.buildIndividualCrossContextXy( + NULL, + "t1", + c("c1", "c2"), + 1e5, + 0, + "lbl", + residualizationParam = common$residualizationParam, + genotypeFilter = common$genotypeFilter, + phenotypeFilter = pf + ) + pecotmr:::.buildIndividualCrossTraitXy( + NULL, + "c1", + c("t1", "t2"), + 1e5, + 0, + "lbl", + "S", + residualizationParam = common$residualizationParam, + genotypeFilter = common$genotypeFilter, + phenotypeFilter = pf + ) + pecotmr:::.composedResidualized( + NULL, + c("c1", "c2"), + c("t1", "t2"), + 1e5, + NULL, + common$residualizationParam, + common$genotypeFilter, + pf + ) + expect_length(seen, 3L) + for (got in seen) { + expect_identical(got, pf) + } +}) diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 1ab2469e..ff0c62df 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -1,112 +1,6 @@ context("LD") library(tidyverse) -# Helper: build an LdData S4 object from variant IDs and optional correlation matrix -makeTestLdData <- function(variant_ids, R = NULL, blockMetadata = NULL) { - if (is.null(R)) { - p <- length(variant_ids) - R <- diag(p) - rownames(R) <- colnames(R) <- variant_ids - } - ref_panel <- pecotmr:::parseVariantId(variant_ids) - ref_panel$variant_id <- variant_ids - variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) - if (is.null(blockMetadata)) { - blockMetadata <- data.frame( - blockId = 1L, - chrom = as.character(ref_panel$chrom[1]), - blockStart = min(ref_panel$pos), - blockEnd = max(ref_panel$pos), - size = length(variant_ids), - startIdx = 1L, - endIdx = length(variant_ids), - stringsAsFactors = FALSE - ) - } - LdData( - correlation = R, - variants = variants_gr, - blockMetadata = blockMetadata - ) -} - -generateDummyData <- function() { - region <- data.frame( - chrom = "chr1", - start = c(1000), - end = c(1190) - ) - meta_df <- data.frame( - chrom = "chr1", - start = c(1000, 1200, 1400, 1600, 1800), - end = c(1200, 1400, 1600, 1800, 2000), - path = c( - "./test_data/LD_block_1.chr1_1000_1200.float16.txt.xz,./test_data/LD_block_1.chr1_1000_1200.float16.bim", - "./test_data/LD_block_2.chr1_1200_1400.float16.txt.xz,./test_data/LD_block_2.chr1_1200_1400.float16.bim", - "./test_data/LD_block_3.chr1_1400_1600.float16.txt.xz,./test_data/LD_block_3.chr1_1400_1600.float16.bim", - "./test_data/LD_block_4.chr1_1600_1800.float16.txt.xz,./test_data/LD_block_4.chr1_1600_1800.float16.bim", - "./test_data/LD_block_5.chr1_1800_2000.float16.txt.xz,./test_data/LD_block_5.chr1_1800_2000.float16.bim" - ) - ) - return(list(region = region, meta = meta_df)) -} - -# Generate a wider region that spans multiple blocks for partition testing -generateMultiBlockData <- function() { - region <- data.frame( - chrom = "chr1", - start = c(1000), - end = c(1500) - ) - meta_df <- data.frame( - chrom = "chr1", - start = c(1000, 1200, 1400, 1600, 1800), - end = c(1200, 1400, 1600, 1800, 2000), - path = c( - "./test_data/LD_block_1.chr1_1000_1200.float16.txt.xz,./test_data/LD_block_1.chr1_1000_1200.float16.bim", - "./test_data/LD_block_2.chr1_1200_1400.float16.txt.xz,./test_data/LD_block_2.chr1_1200_1400.float16.bim", - "./test_data/LD_block_3.chr1_1400_1600.float16.txt.xz,./test_data/LD_block_3.chr1_1400_1600.float16.bim", - "./test_data/LD_block_4.chr1_1600_1800.float16.txt.xz,./test_data/LD_block_4.chr1_1600_1800.float16.bim", - "./test_data/LD_block_5.chr1_1800_2000.float16.txt.xz,./test_data/LD_block_5.chr1_1800_2000.float16.bim" - ) - ) - return(list(region = region, meta = meta_df)) -} - -# LdData stores block metadata as a GRanges, and the block internals read it -# as one (mcols via `$`, blocks via `[` and length()). The fixtures below are -# index-only tables, so a span is synthesised from whatever they carry -- the -# merge and validation logic reads chrom, size and the index range, not the -# span. -.ld_bmGr <- function(df) { - has <- function(n) n %in% names(df) - st <- if (has("blockStart")) { - df$blockStart - } else if (has("startIdx")) { - df$startIdx - } else { - rep(1L, nrow(df)) - } - en <- if (has("blockEnd")) { - df$blockEnd - } else if (has("endIdx")) { - df$endIdx - } else { - rep(1L, nrow(df)) - } - gr <- GenomicRanges::GRanges( - seqnames = as.character(df$chrom), - ranges = IRanges::IRanges(start = as.integer(st), end = as.integer(en)) - ) - keep <- intersect(c("blockId", "size", "startIdx", "endIdx"), names(df)) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - as.data.frame(df[, keep, drop = FALSE]) - ) - gr -} - -# ---- partitionLdMatrix ---- - # ---- orderDedupRegions ---- test_that("orderDedupRegions removes duplicate regions", { @@ -134,24 +28,15 @@ test_that("orderDedupRegions orders and deduplicates across chromosomes", { expect_true(all(diff(result$start[result$chrom == result$chrom[1]]) >= 0)) }) -test_that("orderDedupRegions strips chr prefix", { - df <- data.frame( - chrom = c("chr1", "chr2"), - start = c(100, 200), - end = c(200, 300) - ) - result <- pecotmr:::orderDedupRegions(df) - expect_equal(result$chrom, c("1", "2")) # normalized to a bare string, not integer -}) - test_that("orderDedupRegions sorts X/Y/MT after autosomes and keeps chrom a string", { df <- data.frame( - chrom = c("chrX", "chr2", "chr1", "chrMT"), + chrom = c("chrX", "chr2", "chr1", "chrM"), start = c(1L, 1L, 1L, 1L), end = c(2L, 2L, 2L, 2L) ) result <- pecotmr:::orderDedupRegions(df) - expect_equal(result$chrom, c("1", "2", "X", "MT")) # genomic order, not NA-collapsed + # Genomic order, not alphabetical and not NA-collapsed. + expect_equal(result$chrom, c("chr1", "chr2", "chrX", "chrM")) expect_type(result$chrom, "character") }) @@ -247,18 +132,6 @@ test_that("extractFilePaths errors on missing column", { ) }) -# ---- partitionLdMatrix: different chromosomes ---- - -# ---- extractLdForRegion ---- - -# ---- createLdMatrix ---- - -# ---- validateBlockStructure ---- - -# ---- mergeBlocks ---- - -# ---- canMerge ---- - # =========================================================================== # checkLd (regularize_ld) # =========================================================================== @@ -342,49 +215,27 @@ test_that("checkLd eigenfix does nothing when matrix is already PD", { # =========================================================================== geno_test_data_dir <- test_path("test_data") -geno_region_all <- "chr21:17513228-17592874" - -test_that("resolveLdSource detects PLINK2 from metadata", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_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 <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "plink2") - expect_equal(result$metaPath, meta_file) -}) - -test_that("resolveLdSource detects VCF from metadata", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_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 <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "vcf") -}) - -test_that("resolveLdSource detects GDS from metadata", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_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 <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "gds") +geno_region_all <- GenomicRanges::GRanges("chr21:17513228-17592874") + +test_that("resolveLdSource tells the format of the genotypes metadata names", { + # One row per chromosome naming its genotype file or PLINK prefix, + # resolved beside the metadata file. + rows <- c( + plink2 = "21\t0\t0\ttest_variants", + vcf = "21\t0\t0\ttest_variants.vcf.gz", + gds = "21\t0\t0\ttest_variants.gds", + plink1 = "22\t0\t0\tprotocol_example.genotype" + ) + for (format in names(rows)) { + meta_file <- withr::local_tempfile( + tmpdir = geno_test_data_dir, + fileext = ".tsv" + ) + writeLines(c("chrom\tstart\tend\tpath", rows[[format]]), meta_file) + result <- pecotmr:::resolveLdSource(meta_file) + expect_equal(result$type, format, info = format) + expect_equal(result$metaPath, meta_file, info = format) + } }) test_that("resolveLdSource tells a file's format as readGenotypes does", { @@ -443,22 +294,6 @@ test_that("resolveLdSource errors on missing file", { ) }) -test_that("resolveLdSource errors on 0:0 sentinel with non-genotype path", { - meta_file <- file.path(geno_test_data_dir, "ld_meta_resolve_bad_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "nonexistent_prefix", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - expect_error( - pecotmr:::resolveLdSource(meta_file), - "does not resolve to genotype files" - ) -}) - # =========================================================================== # resolveGenotypePathForRegion # =========================================================================== @@ -493,23 +328,20 @@ test_that("resolveGenotypePathForRegion errors on missing chromosome", { ) }) -# =========================================================================== -# 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 +test_that("resolveGenotypePathForRegion takes a window on one chromosome", { + # A per-chromosome meta names one file per chromosome, so a window over + # two cannot resolve to one path; and a window is a GRanges, not a string. + expect_error( + pecotmr:::resolveGenotypePathForRegion( + "unused.tsv", + GenomicRanges::GRanges(c("chr21:1-10", "chr22:1-10")) + ), + "`region` spans chromosomes chr21, chr22" + ) + expect_error( + pecotmr:::resolveGenotypePathForRegion("unused.tsv", "chr21:1-10"), + "`region` must be a GRanges" ) - result <- pecotmr:::resolveLdSource(meta_file) - expect_equal(result$type, "plink1") }) # =========================================================================== @@ -540,7 +372,10 @@ test_that("regionalLdMeta returns correct file paths for single block", { ) ) writeLines(lines, meta_file) - result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1050-1150") + result <- pecotmr:::regionalLdMeta( + meta_file, + GenomicRanges::GRanges("chr1:1050-1150") + ) expect_true(is.list(result)) expect_true(length(result$intersections$LD_file_paths) >= 1) # All returned paths should exist @@ -576,64 +411,11 @@ test_that("regionalLdMeta spans multiple blocks for wide region", { ) ) writeLines(lines, meta_file) - result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1000-1500") - expect_true(length(result$intersections$LD_file_paths) >= 2) -}) - -# =========================================================================== -# dropCollinearColumns: strategy variants -# =========================================================================== - -test_that("dropCollinearColumns variance strategy removes lowest-variance column", { - set.seed(42) - X <- matrix(rnorm(100 * 4), 100, 4) - colnames(X) <- c("a", "b", "c", "d") - # Make column "c" have near-zero variance - X[, "c"] <- X[1, "c"] - result <- pecotmr:::dropCollinearColumns( - X, - c("b", "c", "d"), - strategy = "variance" - ) - expect_false("c" %in% colnames(result)) - expect_equal(ncol(result), 3L) -}) - -test_that("dropCollinearColumns responseCorrelation strategy works", { - set.seed(42) - X <- matrix(rnorm(100 * 3), 100, 3) - colnames(X) <- c("a", "b", "c") - y <- X[, "a"] + rnorm(100, sd = 0.1) # y correlates strongly with "a" - result <- pecotmr:::dropCollinearColumns( - X, - c("a", "b", "c"), - strategy = "responseCorrelation", - response = y - ) - # Should keep "a" (highest |cor| with response) and remove one of b/c - expect_true("a" %in% colnames(result)) - expect_equal(ncol(result), 2L) -}) - -test_that("dropCollinearColumns responseCorrelation errors without response", { - X <- matrix(1:12, 4, 3) - colnames(X) <- c("a", "b", "c") - expect_error( - pecotmr:::dropCollinearColumns( - X, - c("a", "b"), - strategy = "responseCorrelation" - ), - "response must be supplied" + result <- pecotmr:::regionalLdMeta( + meta_file, + GenomicRanges::GRanges("chr1:1000-1500") ) -}) - -test_that("dropCollinearColumns with single problematic column removes it", { - X <- matrix(rnorm(40), 10, 4) - colnames(X) <- c("a", "b", "c", "d") - result <- pecotmr:::dropCollinearColumns(X, "b", strategy = "correlation") - expect_false("b" %in% colnames(result)) - expect_equal(ncol(result), 3L) + expect_true(length(result$intersections$LD_file_paths) >= 2) }) # =========================================================================== @@ -754,7 +536,7 @@ test_that("ldClumpByScore errors on mismatched chr/pos length", { # ldPruneByCorrelation: verbose paths # =========================================================================== -test_that("ldPruneByCorrelation verbose reports pruning", { +test_that("ldPruneByCorrelation reports pruning only when verbose", { # Create matrix with correlated columns set.seed(42) base <- rnorm(100) @@ -766,6 +548,7 @@ test_that("ldPruneByCorrelation verbose reports pruning", { rnorm(100) ) colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:5)) + expect_silent(ldPruneByCorrelation(X, corThres = 0.5)) expect_message( ldPruneByCorrelation(X, corThres = 0.5, verbose = TRUE), "pruned" @@ -783,46 +566,6 @@ test_that("ldPruneByCorrelation verbose reports no pruning", { ) }) -# ============================================================================= -# loadLdMatrix duplicate variant removal -# ============================================================================= - -test_that("loadLdMatrix dedup removes duplicated variants from result", { - # Simulate what loadLdMatrix does after calling the backend: a result with - # duplicated ldVariants should have duplicates removed. - # We test the dedup logic by constructing a mock result and verifying - # the internal dedup code path via the exported function's contract. - # Since we can't easily call the real function without data, test the dedup - # behavior directly on the result structure. - mat <- matrix(1:16, nrow = 4, ncol = 4) - variants <- c( - "chr1:100:A:G", - "chr1:200:C:T", - "chr1:100:A:G", - "chr1:300:T:A" - ) - ref <- data.frame( - chrom = c(1, 1, 1, 1), - pos = c(100, 200, 100, 300), - A2 = c("A", "C", "A", "T"), - A1 = c("G", "T", "G", "A") - ) - - # Apply the same dedup logic used in loadLdMatrix - dup_idx <- which(duplicated(variants)) - expect_equal(dup_idx, 3L) - - variants_clean <- variants[-dup_idx] - mat_clean <- mat[-dup_idx, -dup_idx, drop = FALSE] - ref_clean <- ref[-dup_idx, , drop = FALSE] - - expect_equal(length(variants_clean), 3) - expect_equal(nrow(mat_clean), 3) - expect_equal(ncol(mat_clean), 3) - expect_equal(nrow(ref_clean), 3) - expect_false(any(duplicated(variants_clean))) -}) - test_data_dir <- test_path("test_data") library(testthat) @@ -841,6 +584,7 @@ test_that("ldPruneByCorrelation removes highly correlated columns", { result <- ldPruneByCorrelation(X, corThres = 0.9) expect_true(ncol(result$X.new) < p) expect_equal(length(result$filter.id), ncol(result$X.new)) + expect_true(all(result$filter.id %in% seq_len(p))) }) test_that("ldPruneByCorrelation keeps all columns when uncorrelated", { @@ -852,6 +596,7 @@ test_that("ldPruneByCorrelation keeps all columns when uncorrelated", { result <- ldPruneByCorrelation(X, corThres = 0.99) expect_equal(ncol(result$X.new), p) expect_equal(result$filter.id, seq_len(p)) + expect_equal(colnames(result$X.new), colnames(X)) }) test_that("ldPruneByCorrelation preserves colnames for single remaining column", { @@ -891,28 +636,6 @@ test_that("ldPruneByCorrelation strict threshold removes at least as many as len expect_true(ncol(result_strict$X.new) <= ncol(result_lenient$X.new)) }) -test_that("ldPruneByCorrelation preserves colnames when no columns deleted", { - set.seed(42) - n <- 100 - p <- 3 - X <- matrix(rnorm(n * p), nrow = n) - colnames(X) <- c("snp_a", "snp_b", "snp_c") - result <- ldPruneByCorrelation(X, corThres = 0.999) - expect_equal(colnames(result$X.new), colnames(X)) -}) - -test_that("ldPruneByCorrelation is silent by default, chatty with verbose", { - set.seed(1) - X <- matrix(rnorm(100), 20, 5) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:5)) - X[, 2] <- X[, 1] + rnorm(20, sd = 1e-3) - expect_silent(ldPruneByCorrelation(X, corThres = 0.9)) - expect_message( - ldPruneByCorrelation(X, corThres = 0.9, verbose = TRUE), - "ldPruneByCorrelation" - ) -}) - # =========================================================================== # dropCollinearColumns # =========================================================================== @@ -920,7 +643,7 @@ test_that("ldPruneByCorrelation is silent by default, chatty with verbose", { # dropCollinearColumns and enforceDesignFullRank are unexported helpers; # access them via pecotmr::: in these tests. -test_that("dropCollinearColumns returns X unchanged when problematicCols is empty", { +test_that("dropCollinearColumns returns X unchanged with no candidates", { X <- matrix(rnorm(100), nrow = 20, ncol = 5) colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:5)) result <- pecotmr:::dropCollinearColumns( @@ -928,7 +651,7 @@ test_that("dropCollinearColumns returns X unchanged when problematicCols is empt problematicCols = character(0), strategy = "correlation" ) - expect_equal(ncol(result), 5) + expect_identical(result, X) }) test_that("dropCollinearColumns removes single problematic column", { @@ -959,31 +682,40 @@ test_that("dropCollinearColumns variance strategy removes lowest variance column expect_false("low_var" %in% colnames(result)) }) -test_that("dropCollinearColumns correlation strategy with two columns removes one", { +test_that("dropCollinearColumns correlation drops one of two candidates", { set.seed(42) X <- matrix(rnorm(100), nrow = 20, ncol = 5) colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:5)) + candidates <- c("chr1:100:A:G", "chr1:200:A:G") result <- pecotmr:::dropCollinearColumns( X, - problematicCols = c("chr1:100:A:G", "chr1:200:A:G"), + problematicCols = candidates, strategy = "correlation" ) - expect_equal(ncol(result), 4) + # Which of the two goes is a random pick, but it is always one of them, + # and every other column comes through untouched. + dropped <- setdiff(colnames(X), colnames(result)) + expect_length(dropped, 1L) + expect_true(is_in(dropped, candidates)) + expect_identical(result, X[, colnames(X) != dropped]) }) -test_that("dropCollinearColumns correlation strategy with 3+ cols removes highest sum", { +test_that("dropCollinearColumns correlation drops the highest-sum candidate", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 4), nrow = n, ncol = 4) colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:4)) - X[, 2] <- X[, 1] + rnorm(n, sd = 0.01) - X[, 3] <- X[, 1] + rnorm(n, sd = 0.01) + # chr1:200 is built from both of the other candidates, which are + # independent of each other, so its sum of |cor| with them is the + # largest by a wide margin. It sits mid-list, so neither the first nor + # the last candidate would pass for it. + X[, 2] <- X[, 1] + X[, 3] + rnorm(n, sd = 0.1) result <- pecotmr:::dropCollinearColumns( X, problematicCols = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), strategy = "correlation" ) - expect_equal(ncol(result), 3) + expect_identical(result, X[, -2L]) }) test_that("dropCollinearColumns responseCorrelation strategy removes lowest |cor| with response", { @@ -1011,7 +743,7 @@ test_that("dropCollinearColumns errors on responseCorrelation without response", problematicCols = c("chr1:100:A:G", "chr1:200:A:G"), strategy = "responseCorrelation" ), - "response" + "response must be supplied" ) }) @@ -1055,17 +787,6 @@ test_that("dropCollinearColumns is silent by default", { # enforceDesignFullRank (unexported) # =========================================================================== -test_that("enforceDesignFullRank returns full-rank matrix when already full rank", { - set.seed(42) - n <- 50 - X <- matrix(rnorm(n * 3), nrow = n, ncol = 3) - colnames(X) <- sprintf("chr1:%d:A:G", 100L * (1:3)) - C <- matrix(rnorm(n * 2), nrow = n, ncol = 2) - result <- enforceDesignFullRank(X = X, C = C, strategy = "correlation") - expect_true(is.matrix(result)) - expect_true(ncol(result) >= 1) -}) - test_that("enforceDesignFullRank handles rank-deficient design via correlation fallback", { set.seed(42) n <- 50 @@ -1102,43 +823,7 @@ test_that("enforceDesignFullRank is silent by default", { # ldClumpByScore # =========================================================================== -test_that("ldClumpByScore skips clumping on single-column input", { - skip_if_not_installed("bigsnpr") - skip_if_not_installed("bigstatsr") - set.seed(1) - X <- matrix(rbinom(100, 2, 0.3), 100, 1) - colnames(X) <- "chr1:100:A:G" - keep <- ldClumpByScore(X, score = 1.0, chr = 1L, pos = 100L, r2 = 0.2) - expect_equal(keep, 1L) -}) - -test_that("ldClumpByScore validates input lengths", { - skip_if_not_installed("bigsnpr") - skip_if_not_installed("bigstatsr") - set.seed(1) - X <- matrix(rbinom(100 * 3, 2, 0.3), 100, 3) - colnames(X) <- paste0("chr1:", seq_len(3) * 1000, ":A:G") - expect_error( - ldClumpByScore( - X, - score = 1:2, - chr = rep(1L, 3), - pos = seq_len(3) * 1000L - ), - "score" - ) - expect_error( - ldClumpByScore( - X, - score = 1:3, - chr = rep(1L, 2), - pos = seq_len(3) * 1000L - ), - "chr.*Must have length 3" - ) -}) - -test_that("ldClumpByScore returns indices on real data", { +test_that("ldClumpByScore drops the lower-scoring copy of a perfect-LD pair", { skip_if_not_installed("bigsnpr") skip_if_not_installed("bigstatsr") set.seed(1) @@ -1161,72 +846,58 @@ test_that("ldClumpByScore returns indices on real data", { # Tests migrated from test_misc.R (computeLd + .findValidFilePath*) # =========================================================================== +# The fixtures sit in test_data, which R CMD check copies with the tests, +# unlike the package root's own files. +.ldBed <- test_path("test_data", "protocol_example.genotype.bed") + test_that("findValidFilePath returns target when it exists directly", { - pkg_root <- normalizePath( - file.path(test_path(), "..", ".."), - mustWork = TRUE - ) - target <- file.path(pkg_root, "DESCRIPTION") - ref <- file.path(pkg_root, "NAMESPACE") - skip_if_not( - file.exists(target) && file.exists(ref), - "Package root files not found" - ) + target <- test_path("test_data", "protocol_example.genotype.bim") result <- pecotmr:::.findValidFilePath( - referenceFilePath = ref, + referenceFilePath = .ldBed, targetFilePath = target ) expect_equal(result, target) }) test_that("findValidFilePath constructs path from reference directory", { - pkg_root <- normalizePath( - file.path(test_path(), "..", ".."), - mustWork = TRUE - ) - ref <- file.path(pkg_root, "NAMESPACE") - skip_if_not(file.exists(ref), "NAMESPACE not found") result <- pecotmr:::.findValidFilePath( - referenceFilePath = ref, - targetFilePath = "DESCRIPTION" + referenceFilePath = .ldBed, + targetFilePath = "protocol_example.genotype.bim" + ) + expect_equal( + result, + test_path("test_data", "protocol_example.genotype.bim") ) - expect_true(file.exists(result)) - expect_true(grepl("DESCRIPTION$", result)) }) test_that("findValidFilePath errors when both paths are invalid", { expect_error( pecotmr:::.findValidFilePath( referenceFilePath = "/nonexistent/dir/ref.txt", - targetFilePath = "/nonexistent/target.txt" + targetFilePath = "target.txt" + ), + str_c( + "Both reference and target file paths do not work. Tried paths: ", + "'/nonexistent/dir/ref.txt' and '/nonexistent/dir/target.txt'" ), - "Both reference and target file paths do not work" + fixed = TRUE ) }) test_that("findValidFilePath returns reference when target is invalid but reference exists", { - pkg_root <- normalizePath( - file.path(test_path(), "..", ".."), - mustWork = TRUE - ) - ref <- file.path(pkg_root, "DESCRIPTION") - skip_if_not(file.exists(ref), "DESCRIPTION not found") result <- pecotmr:::.findValidFilePath( - referenceFilePath = ref, + referenceFilePath = .ldBed, targetFilePath = "/totally/bogus/path.txt" ) - expect_equal(result, ref) + expect_equal(result, .ldBed) }) test_that("findValidFilePaths resolves multiple targets", { - pkg_root <- normalizePath( - file.path(test_path(), "..", ".."), - mustWork = TRUE - ) - ref <- file.path(pkg_root, "NAMESPACE") - skip_if_not(file.exists(ref), "NAMESPACE not found") - targets <- c("DESCRIPTION", "NAMESPACE") - result <- pecotmr:::.findValidFilePaths(ref, targets) + targets <- c( + "protocol_example.genotype.bim", + "protocol_example.genotype.fam" + ) + result <- pecotmr:::.findValidFilePaths(.ldBed, targets) expect_length(result, 2) expect_true(all(file.exists(result))) }) @@ -1299,29 +970,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) - colnames(X) <- paste0("rs", 1:100) - - R <- computeLd(X, method = "sample") - expect_equal(dim(R), c(100L, 100L)) - expect_equal(unname(diag(R)), rep(1, 100)) - expect_true(isSymmetric(R)) - 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) - colnames(X) <- paste0("rs", 1:100) - - R <- computeLd(X, method = "population") - expect_equal(dim(R), c(100L, 100L)) - expect_equal(unname(diag(R)), rep(1, 100)) - 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) @@ -1333,17 +981,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) - colnames(X) <- paste0("rs", 1:3) - - R_trimmed <- computeLd(X, method = "population", trimSamples = TRUE) - expect_equal(dim(R_trimmed), c(3L, 3L)) - R_full <- computeLd(X, method = "population", trimSamples = FALSE) - 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") @@ -1380,18 +1017,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) - X[1, 1] <- NA - X[5, 3] <- NA - colnames(X) <- paste0("rs", 1:4) - - R <- computeLd(X, method = "sample") - expect_true(all(!is.na(R))) - expect_equal(unname(diag(R)), rep(1, 4)) -}) - test_that("computeLd errors on NULL input", { expect_error(computeLd(NULL), "X must be provided") }) @@ -1454,19 +1079,9 @@ test_that("computeLd gcta preserves column names", { }) # ============================================================================= -# waldTestPval +# computeLd: trimSamples and shrinkage # ============================================================================= -test_that("computeLd sample method without Rfast falls back to cor", { - set.seed(42) - X <- matrix(sample(0:2, 100, replace = TRUE), nrow = 20, ncol = 5) - colnames(X) <- paste0("snp", 1:5) - R <- computeLd(X, method = "sample") - expect_equal(dim(R), c(5, 5)) - expect_equal(as.numeric(diag(R)), rep(1, 5)) - 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) @@ -1484,6 +1099,8 @@ test_that("computeLd population method with trim_samples", { R <- computeLd(X, method = "population", trimSamples = TRUE) expect_equal(dim(R), c(5, 5)) expect_equal(as.numeric(diag(R)), rep(1, 5)) + # 21 samples trim to the first 20, a multiple of four. + expect_equal(R, computeLd(X[1:20, ], method = "population")) }) test_that("computeLd with shrinkage > 0", { @@ -1500,13 +1117,51 @@ test_that("computeLd with shrinkage > 0", { expect_equal(off_diag_s, 0.9 * off_diag_no) }) +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("gdsfmt") + 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), rownames(panel)[1:6]) +}) + +test_that("computeLd returns identity for a single-variant block", { + skip_if_not_installed("pgenlibr") + td <- test_path("test_data") + handle <- readGenotypeHandle( + file.path(td, "test_variants"), + format = "plink2" + ) + R <- computeLd(handle, snpIdx = 1L, backend = "internal") + expect_equal(R, diag(1)) +}) + +test_that("computeLd on a panel computes via the general path", { + skip_if_not_installed("pgenlibr") + td <- test_path("test_data") + handle <- readGenotypeHandle( + file.path(td, "test_variants"), + format = "plink2" + ) + R <- computeLd(handle, snpIdx = 1:5, backend = "internal") + expect_equal(dim(R), c(5L, 5L)) + expect_equal(unname(diag(R)), rep(1, 5), tolerance = 1e-6) +}) + # ============================================================================= # Additional coverage: findIntersectionRows / regionalLdMeta edge cases # ============================================================================= test_that("findIntersectionRows errors when region falls in a coverage gap", { # Chromosome exists but there is a gap between the two blocks; after - # clamping, no single row covers the query start -> stop (line 33). + # clamping, no single row covers the query start -> error. gd <- data.frame(chrom = c(1, 1), start = c(100, 300), end = c(150, 350)) expect_error( pecotmr:::findIntersectionRows(gd, 1, 200, 250), @@ -1530,10 +1185,13 @@ test_that("regionalLdMeta handles whole-chromosome 0:0 sentinel rows", { file = meta_file, append = TRUE ) - result <- pecotmr:::regionalLdMeta(meta_file, "chr1:1000-1190") + result <- pecotmr:::regionalLdMeta( + meta_file, + GenomicRanges::GRanges("chr1:1000-1190") + ) expect_true(length(result$intersections$LD_file_paths) >= 1) expect_true(all(file.exists(result$intersections$LD_file_paths))) - # 0:0 sentinel row should have had its end set to Inf internally (line 103) + # 0:0 sentinel row should have had its end set to Inf internally expect_true(is.infinite(max(result$ldMetaData$end))) }) @@ -1551,10 +1209,10 @@ test_that("regionalLdMeta validates complete coverage when required", { ) ) writeLines(lines, meta_file) - # Region fully inside block 1 -> validateSelectedRegion passes (line 122) + # Region fully inside block 1 -> validateSelectedRegion passes result <- pecotmr:::regionalLdMeta( meta_file, - "chr1:1050-1150", + GenomicRanges::GRanges("chr1:1050-1150"), completeCoverageRequired = TRUE ) expect_true(length(result$intersections$LD_file_paths) >= 1) @@ -1629,18 +1287,6 @@ test_that(".ldFromRef matches non-prefixed ids to a chr-prefixed panel", { expect_equal(rownames(m), req) # caller's labels preserved }) -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:::.ldFromRef(h, pid[1:3]) - expect_equal(dim(m), c(3L, 3L)) - expect_equal(rownames(m), pid[1:3]) -}) - test_that(".ldFromRef still errors on a variant absent after reconciling", { skip_if_not_installed("pgenlibr") h <- readGenotypeHandle( @@ -1676,7 +1322,7 @@ test_that(".ldFromRef rejects an ldReference that is not a genotype panel", { format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snpN)), - CHR = rep("1", snpN), + CHR = rep("chr1", snpN), BP = seq(100L, by = 100L, length.out = snpN), A1 = rep("A", snpN), A2 = rep("G", snpN), @@ -1773,11 +1419,11 @@ test_that(".ldFromRef leaves LD untouched when every allele agrees", { .package = "pecotmr" ) ids <- c("chr1:200:A:G", "chr1:400:A:G") - expect_equal( - pecotmr:::.ldFromRef(h, ids), - pecotmr:::.ldFromRef(h, ids), - tolerance = 1e-12 - ) + # The sample correlation of the very dosages the panel serves for those + # variants: with no allele to flip, no sign may change. + served <- .lds_mockExtractor()(h, c(2L, 4L)) + direct <- cor(t(SummarizedExperiment::assay(served, "dosage"))) + expect_equal(pecotmr:::.ldFromRef(h, ids), direct, tolerance = 1e-12) }) test_that(".ldFromRef errors on a variant the panel does not carry", { @@ -1835,7 +1481,7 @@ test_that(".requireMatchingLdRefs accepts panels trimmed differently", { # surviving variant set. The panels overlap but are not identical. si <- data.frame( SNP = c("1:100:A:G", "1:200:C:T", "1:300:G:A", "1:400:T:C"), - CHR = rep("1", 4L), + CHR = rep("chr1", 4L), BP = c(100L, 200L, 300L, 400L), A1 = c("A", "C", "G", "T"), A2 = c("G", "T", "A", "C"), @@ -1869,7 +1515,7 @@ test_that(".requireMatchingLdRefs errors when panels share no variant", { mkSi <- function(bp) { data.frame( SNP = str_c("1:", bp, ":A:G"), - CHR = rep("1", length(bp)), + CHR = rep("chr1", length(bp)), BP = as.integer(bp), A1 = rep("A", length(bp)), A2 = rep("G", length(bp)), @@ -1901,7 +1547,7 @@ test_that(".requireMatchingLdRefs errors when panels share no variant", { test_that(".requireMatchingLdRefs errors on a different sample set", { si <- data.frame( SNP = "1:100:A:G", - CHR = "1", + CHR = "chr1", BP = 100L, A1 = "A", A2 = "G", @@ -1929,17 +1575,16 @@ test_that(".requireMatchingLdRefs errors on a different sample set", { ) }) -test_that(".requireMatchingLdRefs tolerates a chr-prefix-only difference", { +test_that(".requireMatchingLdRefs tolerates chr-prefixed SNP labels", { si1 <- data.frame( SNP = c("1:100:A:G", "1:200:C:T"), - CHR = c("1", "1"), + CHR = c("chr1", "chr1"), BP = c(100L, 200L), A1 = c("A", "C"), A2 = c("G", "T"), stringsAsFactors = FALSE ) si2 <- si1 - si2$CHR <- c("chr1", "chr1") si2$SNP <- c("chr1:100:A:G", "chr1:200:C:T") # same panel, chr-prefixed mk <- function(si) { new( @@ -2287,43 +1932,6 @@ test_that("computeLd errors when a non-internal backend is paired with non-sampl ) }) -# The Rfast-absent fallback branches (computeLd's `R <- cor(X_imp)` and -# ldPruneByCorrelation's `cor.X <- cor(X)`) are reachable by mocking the *base* -# `requireNamespace` (so it reports Rfast missing) for the duration of the call. -test_that("ldPruneByCorrelation and computeLd fall back to base cor() when Rfast is absent", { - # Captured BEFORE the rebinding: inside the mock, `base::requireNamespace` - # resolves to the mock itself, so delegating through it recurses. - realRequireNamespace <- base::requireNamespace - with_mocked_bindings( - { - set.seed(1) - X <- matrix(rnorm(50 * 4), 50, 4) - colnames(X) <- paste0("s", 1:4) - pruned <- ldPruneByCorrelation(X, corThres = 0.9) # hits cor(X) at ld.R:1207 - R <- computeLd(X, method = "sample", backend = "internal") # hits cor(X_imp) at ld.R:1816 - expect_true(is.list(pruned)) - expect_true(all(c("X.new", "filter.id") %in% names(pruned))) - expect_equal(dim(R), c(4L, 4L)) - expect_equal(unname(diag(R)), rep(1, 4), tolerance = 1e-8) - expect_true(isSymmetric(unname(R))) - # base cor() fallback must agree with the direct base computation. - expect_equal(unname(R), unname(cor(X)), tolerance = 1e-10) - }, - requireNamespace = function(package, ...) { - if (identical(package, "Rfast")) { - FALSE - } else { - realRequireNamespace(package, ...) - } - }, - .package = "base" - ) -}) - -# ============================================================================= -# detectVariantConvention — uncovered line 586 -# ============================================================================= - # --------------------------------------------------------------------------- # .panelVariantStats / .panelVariantFilter # @@ -2733,19 +2341,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. - expect_equal( - pecotmr:::.panelVariantFilter(NULL, c("v1", "v2")), - c("v1", "v2") - ) - expect_equal( - pecotmr:::.panelVariantFilter(NULL, character(0)), - character(0) - ) -}) - # =========================================================================== # Empty sketches, the .afreq fast path, and design rank # =========================================================================== @@ -2761,7 +2356,7 @@ test_that("emptying a sketch clears both axes", { format = "plink2", snpInfo = data.frame( SNP = c("a", "b"), - CHR = "1", + CHR = "chr1", BP = 1:2, A1 = "A", A2 = "G", @@ -2777,17 +2372,50 @@ test_that("emptying a sketch clears both axes", { expect_equal(length(pecotmr:::sampleIds(e)), 0L) }) +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 <- .emptyLdRef(h) + expect_equal(nrow(e), 0L) + expect_null(.panelSeed(e)) + expect_lt( + length(serialize(e, NULL)), + length(serialize(h, NULL)) / 2 + ) +}) + +test_that(".emptyLdRef is NULL-safe and idempotent", { + expect_null(.emptyLdRef(NULL)) + e <- .emptyLdRef(.sk_panel()) + expect_equal(nrow(.emptyLdRef(e)), 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("a missing or malformed afreq sidecar degrades to no frequencies", { # The sidecar is optional; a bad one must not take the whole filter down, # it just falls back to reading dosage. expect_null(pecotmr:::.panelAfreqTable("/nonexistent/prefix")) + prefix <- file.path(withr::local_tempdir(), "panel") + sidecar <- str_c(prefix, ".afreq") h <- new( "GenotypeHandle", - path = "/tmp/x", + path = prefix, format = "plink2", snpInfo = data.frame( SNP = c("a", "b"), - CHR = "1", + CHR = "chr1", BP = 1:2, A1 = "A", A2 = "G", @@ -2800,6 +2428,32 @@ test_that("a missing or malformed afreq sidecar degrades to no frequencies", { ) # No sidecar beside the file: nothing to read, in any format. expect_null(.pvfAfreqMaf(h, c("a", "b"))) + # A well-formed sidecar there is read ... + writeLines( + c( + "#CHROM\tID\tREF\tALT\tALT_FREQS\tOBS_CT", + "1\ta\tG\tA\t0.1\t4", + "1\tb\tG\tA\t0.8\t4" + ), + sidecar + ) + expect_equal(.pvfAfreqMaf(h, c("a", "b")), c(0.1, 0.2)) + # ... and a malformed one degrades to no frequencies: one without + # ALT_FREQS, which the reader refuses, or one that is not a table. + writeLines( + c( + "#CHROM\tID\tREF\tALT\tOBS_CT", + "1\ta\tG\tA\t4", + "1\tb\tG\tA\t4" + ), + sidecar + ) + expect_error(readAfreq(prefix), "ALT_FREQS") + expect_null(pecotmr:::.panelAfreqTable(prefix)) + expect_null(.pvfAfreqMaf(h, c("a", "b"))) + writeLines("not an afreq file", sidecar) + expect_null(pecotmr:::.panelAfreqTable(prefix)) + expect_null(.pvfAfreqMaf(h, c("a", "b"))) }) test_that("collinear design columns are reported, full-rank ones are not", { @@ -2827,50 +2481,6 @@ test_that("computeLd refuses snpIdx against an already-materialized block", { ) }) -# =========================================================================== -# Block-indexed sources and LdData subsetting -# =========================================================================== - -# --------------------------------------------------------------------------- -# LdData narrowing and materialization: each genotype source shape (matrix, -# handle + snpIdx, mixture list) narrows differently, and only the matrix -# shape can be materialized. -# --------------------------------------------------------------------------- - -.ldcov_gr <- function(variant_ids, af = NULL) { - rp <- pecotmr:::parseVariantId(variant_ids) - rp$variant_id <- variant_ids - if (!is.null(af)) { - rp$allele_freq <- af - } - pecotmr:::.refPanelToGranges(rp) -} - -.ldcov_bm <- function(n) { - data.frame( - blockId = 1L, - chrom = "chr1", - blockStart = 100, - blockEnd = 100 * n, - size = n, - startIdx = 1L, - endIdx = n, - stringsAsFactors = FALSE - ) -} - -.ldcov_handle <- function() { - new( - "GenotypeHandle", - path = "/tmp/test", - format = "plink2", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) -} - test_that(".ldRefMatchIds returns bare ids when alleles are absent", { gr <- GenomicRanges::GRanges( "chr1", @@ -2888,26 +2498,16 @@ test_that(".ldRefMatchIds returns bare ids when alleles are absent", { ) }) -test_that(".panelVariantFilter is a no-op without a sketch", { - v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") - # An active cutoff still cannot filter anything with no panel to read - # frequencies from. - expect_equal( - pecotmr:::.panelVariantFilter( - NULL, - v, - PanelFilterParam(mafCutoff = 0.01) - ), - v - ) - expect_equal( - pecotmr:::.panelVariantFilter( - NULL, - character(0), - PanelFilterParam(mafCutoff = 0.01) - ), - character(0) - ) +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:::.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:::.ldRefVariantIds(h)[-2L]) + # the raw accessor still answers the panel FILE's label (.afreq keys on it) + expect_equal(pecotmr:::.ldRefVariantIds(h)[2L], "chr1:200:INS:A") }) test_that(".panelVariantFilter is a no-op when nothing matches the panel", { @@ -3070,21 +2670,91 @@ test_that("computeLd(onDisk) applies shrinkage toward the identity", { ) }) -# --------------------------------------------------------------------------- -# .ldInfoBlock: an `ldInfo` row names the LD matrix, and the variant metadata -# is either named alongside it or auto-detected from the LD path. -# --------------------------------------------------------------------------- +test_that("onDisk LD matches the in-memory path on complete data", { + skip_if_not_installed("SNPRelate") + 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, + snpIdx = idx, + backend = "snprelate", + onDisk = TRUE + ) + inMem <- computeLd(handle, snpIdx = idx) + # The fixture has no missing calls, which is the only regime where the + # two are meant to agree. + expect_equal(unname(onDisk), unname(inMem), tolerance = 1e-8) +}) + +test_that("onDisk LD labels and orders by the request", { + skip_if_not_installed("SNPRelate") + 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), + 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") + 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), + "GDS-backed panel" + ) + expect_error( + computeLd(gds, backend = "internal", onDisk = TRUE), + "only available for" + ) + expect_error( + computeLd(matrix(1, 4, 3), backend = "snprelate", onDisk = TRUE), + "must be one" + ) + expect_error( + computeLd(gds, method = "gcta", backend = "snprelate", onDisk = TRUE), + "sample correlation" + ) +}) -test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { +test_that("LD from a sketch does not depend on the request order", { skip_if_not_installed("pgenlibr") - # This plink2 fixture ships without an .afreq, so every shard's table is - # absent -- distinct from the partial-sidecar case above. handle <- readGenotypeHandle( - test_path("test_data/test_variants_chr22"), + test_path("test_data", "test_variants"), format = "plink2" ) - expect_equal(pecotmr:::genotypeFormat(handle), "plink2") - expect_null(.pvfAfreqMaf(handle, as.character(snpInfo(handle)$SNP))) + ids <- snpInfo(handle)$SNP[1:6] + shuffled <- ids[c(4L, 1L, 6L, 2L, 5L, 3L)] + 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]) +}) + +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 = test_path("test_data", "test_variants") + ) + cut <- pecotmr:::.panelSubsetRows(panel, c(3L, 10L, 200L)) + # 100 samples in the panel + expect_equal(dim(pecotmr:::.panelSeed(cut)), c(3L, 100L)) + expect_equal(.dose(cut), .dose(panel)[c(3L, 10L, 200L), ]) + saved <- tempfile(fileext = ".rds") + saveRDS(cut, saved) + expect_equal(.dose(readRDS(saved)), .dose(cut)) }) test_that("ldReference cross-checks are no-ops when a side has no variants", { @@ -3165,26 +2835,6 @@ test_that("ldPruneByCorrelation forwards methodArgs to SNPRelate", { expect_equal(seen$ld.threshold, 0.9) }) -test_that(".panelCutoffs answers NULL for a filter that keeps everything", { - expect_null(pecotmr:::.panelCutoffs(PanelFilterParam())) - expect_equal( - pecotmr:::.panelCutoffs(PanelFilterParam(mafCutoff = 0.01))$mafCutoff, - 0.01 - ) -}) - -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 # ============================================================================= @@ -3344,6 +2994,10 @@ test_that("a stochastic sketch records its real size and frequencies", { skip_if_not_installed("pgenlibr") sketch <- .ldrefSketch() expect_true(pecotmr:::.ldRefIsProjection(sketch)) + # 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. + expect_equal(pecotmr:::.ldRefNSamples(sketch), 100L) 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. @@ -3555,3 +3209,299 @@ test_that("a panel held in memory serves as an LD reference", { expect_equal(dim(pecotmr:::.ldRefSubset(mem, 3:7)), c(5L, ncol(mem))) expect_equal(dim(pecotmr:::.emptyLdRef(mem)), c(0L, 0L)) }) + +# =========================================================================== +# Per-row LD references +# =========================================================================== + +# An LdMatrix over five chr1 variants at 100 bp spacing. +.ldr_ldm <- function(rho = 0.2, chrom = "chr1") { + ids <- sprintf("%s:%d:A:G", chrom, 100L * (1:5)) + r <- rho^abs(outer(1:5, 1:5, "-")) + LdMatrix(`dimnames<-`(r, list(ids, ids))) +} + +# A QtlSumStats of one tuple per reference in `refs`, every tuple over the same +# five variants on `chrom`. +.ldr_qss <- function(refs, chrom = "chr1") { + n <- length(refs) + gr <- GenomicRanges::GRanges( + chrom, + IRanges::IRanges(100L * (1:5), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("%s:%d:A:G", chrom, 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = seq_len(5) / 10, + N = 100L + ) + QtlSumStats( + studyName = rep("s1", n), + context = str_c("c", seq_len(n)), + trait = rep("t1", n), + entry = rep(list(gr), n), + genome = "hg19", + ldReference = refs + ) +} + +test_that(".ldRefPerTuple reads one reference or one per tuple", { + a <- .ldr_ldm() + b <- .ldr_ldm(rho = 0.5) + expect_identical(pecotmr:::.ldRefPerTuple(a, 3L), list(a, a, a)) + # What ldReference() returns reads the same way: a one-entry list is that + # reference for every tuple, an empty one is LD-free. + expect_identical(pecotmr:::.ldRefPerTuple(list(ld1 = a), 2L), list(a, a)) + expect_identical(pecotmr:::.ldRefPerTuple(list(), 2L), list(NULL, NULL)) + expect_identical(pecotmr:::.ldRefPerTuple(NULL, 2L), list(NULL, NULL)) + expect_identical(pecotmr:::.ldRefPerTuple(list(a, b), 2L), list(a, b)) + expect_error(pecotmr:::.ldRefPerTuple(list(a, b), 3L), "one per tuple") +}) + +test_that(".ldRefDict stores each distinct reference once and keys every row", { + a <- .ldr_ldm() + b <- .ldr_ldm(rho = 0.5) + # An equal copy built separately is the same reference, not a second one. + dict <- pecotmr:::.ldRefDict(list(a, NULL, b, a, .ldr_ldm())) + expect_identical(dict$refs, list(ld1 = a, ld2 = b)) + expect_identical(dict$keys, c("ld1", NA, "ld2", "ld1", "ld1")) + expect_identical(pecotmr:::.ldRefDict(list(NULL))$refs, list()) +}) + +test_that("a collection keeps each row on its own reference, stored once", { + a <- .ldr_ldm() + b <- .ldr_ldm(rho = 0.5) + qss <- .ldr_qss(list(a, b, a)) + expect_identical(ldReference(qss), list(ld1 = a, ld2 = b)) + expect_identical(qss$ldReference, c("ld1", "ld2", "ld1")) + expect_identical(pecotmr:::.rowLdRefs(qss), list(a, b, a)) + # A subset reports only the references its rows still use. + expect_identical(ldReference(qss[c(1L, 3L)]), list(ld1 = a)) + expect_output(show(qss), "2 references") +}) + +test_that("validity refuses a row keyed to a reference the slot lacks", { + qss <- .ldr_qss(list(.ldr_ldm())) + expect_error( + { + qss$ldReference <- "ld9" + methods::validObject(qss) + }, + "not in ldReference: ld9" + ) +}) + +test_that("an object saved before per-row references is refused", { + # Read as a list, its single reference would pass for LD-free. + old <- .ldr_qss(list(.ldr_ldm())) + attr(old, "ldReference") <- .ldr_ldm() + md <- attr(old, "elementMetadata") + md[["ldReference"]] <- NULL + attr(old, "elementMetadata") <- md + expect_error(ldReference(old), "saved before LD references became") +}) + +test_that(".withRowLdRefs puts every row on one reference", { + a <- .ldr_ldm() + b <- .ldr_ldm(rho = 0.5) + moved <- pecotmr:::.withRowLdRefs(.ldr_qss(list(a, b)), b) + expect_identical(ldReference(moved), list(ld1 = b)) + expect_identical(moved$ldReference, c("ld1", "ld1")) + expect_true(methods::validObject(moved)) +}) + +test_that(".requireMatchingRowLdRefs checks only the pairs it is given", { + a <- .ldr_ldm() + qtl <- .ldr_qss(list(a, .ldr_ldm(rho = 0.5))) + gwas <- .ldr_qss(list(a)) + # QTL row 1 shares the GWAS row's reference; row 2 does not, but is only + # refused when it is paired with it. + expect_null(pecotmr:::.requireMatchingRowLdRefs(qtl, gwas, 1L, 1L, "p")) + expect_error( + pecotmr:::.requireMatchingRowLdRefs(qtl, gwas, 2L, 1L, "p"), + "disagree on the LD" + ) +}) + +test_that(".overlappingRowPairs pairs rows whose regions overlap", { + a <- .ldr_ldm() + qtl <- combineQtlSumStats( + .ldr_qss(list(a)), + .ldr_qss(list(.ldr_ldm(chrom = "chr2")), chrom = "chr2") + ) + pairs <- pecotmr:::.overlappingRowPairs(qtl, .ldr_qss(list(a))) + expect_identical(pairs, list(qtlRows = 1L, gwasRows = 1L)) + # Collections on no common chromosome have no pairs, and say nothing. + expect_silent( + none <- pecotmr:::.overlappingRowPairs( + qtl, + .ldr_qss(list(.ldr_ldm(chrom = "chr3")), chrom = "chr3") + ) + ) + expect_identical(none, list(qtlRows = integer(0), gwasRows = integer(0))) +}) + +test_that(".overlapsOnShared compares ranges on the chromosomes both have", { + q <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 100L), width = 10L) + ) + s <- GenomicRanges::GRanges("chr2", IRanges::IRanges(105L, width = 1L)) + expect_identical(pecotmr:::.overlapsOnShared(q, s), c(FALSE, TRUE)) + # With no chromosome in common nothing overlaps, and nothing is said. + far <- GenomicRanges::GRanges("chr3", IRanges::IRanges(100L, width = 1L)) + expect_silent(none <- pecotmr:::.overlapsOnShared(q, far)) + expect_identical(none, c(FALSE, FALSE)) + # Strand says nothing about where a variant or a block sits. + minus <- GenomicRanges::GRanges( + "chr2", + IRanges::IRanges(105L, width = 1L), + strand = "-" + ) + plus <- GenomicRanges::`strand<-`(q, value = "+") + expect_identical(pecotmr:::.overlapsOnShared(plus, minus), c(FALSE, TRUE)) +}) + +test_that(".locusRanges keeps where ranges sit and the build, nothing else", { + gr <- GenomicRanges::GRanges( + c("chr1", "chrM"), + IRanges::IRanges(c(100L, 5L), width = 1L), + strand = c("+", "-"), + SNP = c("a", "b") + ) + GenomeInfoDb::genome(gr) <- "hg19" + out <- pecotmr:::.locusRanges(gr) + expect_identical( + as.character(GenomicRanges::seqnames(out)), + c("chr1", "chrM") + ) + expect_identical(as.character(GenomicRanges::strand(out)), c("*", "*")) + expect_identical(ncol(S4Vectors::mcols(out)), 0L) + expect_identical(unname(GenomeInfoDb::genome(out)), c("hg19", "hg19")) +}) + +test_that("ranges on two genome builds refuse to meet", { + q <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 10L)) + s <- GenomicRanges::GRanges("chr1", IRanges::IRanges(105L, width = 1L)) + GenomeInfoDb::genome(q) <- "hg19" + GenomeInfoDb::genome(s) <- "hg38" + expect_error(pecotmr:::.overlapsOnShared(q, s), "incompatible genomes") +}) + +test_that(".rowsSharedLdRef returns the rows' one reference or refuses", { + a <- .ldr_ldm() + qss <- .ldr_qss(list(a, .ldr_ldm(rho = 0.5), a)) + expect_identical(pecotmr:::.rowsSharedLdRef(qss, c(1L, 3L), "rows"), a) + expect_error( + pecotmr:::.rowsSharedLdRef(qss, 1:2, "these rows"), + "these rows use 2 different LD references" + ) +}) + +# =========================================================================== +# On a real genotype panel: checkLd, ldClumpByScore, enforceDesignFullRank, +# filterVariantsByLdReference +# =========================================================================== + +# Fixtures: 100 samples x 349 variants on chr21 +plink_prefix <- test_path("test_data", "test_variants") + +# The panel's genotype matrix and variant info +loadTestGenotype <- function() { + loadGenotypeRegion(plink_prefix, returnVariantInfo = TRUE) +} + +# --- checkLd ---------------------------------------------------------------- + +test_that("checkLd reports a rank-deficient sample LD matrix as PSD", { + skip_if_not_installed("pgenlibr") + X <- loadTestGenotype()$X + # 100 samples cap the rank at 99 of 349 variants. + R <- computeLd(X, method = "sample") + result <- checkLd(R) + expect_true(is.list(result)) + expect_false(result$isPd) + expect_true(result$isPsd) + expect_equal(result$methodApplied, "none") + # min eigenvalue may be near-zero (numerically PSD, not strictly PD) + expect_true(result$minEigenvalue > -1e-7) + expect_true(result$nNegative == 0) + expect_true(is.finite(result$conditionNumber)) +}) + +# --- ldClumpByScore ------------------------------------------------------- + +test_that("ldClumpByScore takes UCSC chromosome labels on a real panel", { + skip_if_not_installed("pgenlibr") + skip_if_not_installed("bigsnpr") + skip_if_not_installed("bigstatsr") + geno <- loadTestGenotype() + set.seed(42) + score <- runif(ncol(geno$X)) + # UCSC labels (chr21) are taken as they are. + chr <- geno$variant_info$chrom + pos <- geno$variant_info$pos + keep <- ldClumpByScore( + geno$X, + score = score, + chr = chr, + pos = pos, + r2 = 0.2 + ) + expect_true(is.integer(keep)) + expect_true(length(keep) > 0) + expect_true(length(keep) <= ncol(geno$X)) + expect_true(all(keep %in% seq_len(ncol(geno$X)))) +}) + +# --- enforceDesignFullRank ------------------------------------------------ + +test_that("enforceDesignFullRank handles genotype matrix with covariates", { + skip_if_not_installed("pgenlibr") + X <- loadTestGenotype()$X + # Create a simple covariate matrix (e.g., first 2 PCs of X) + pca <- prcomp(X, rank. = 2) + C <- pca$x + result <- enforceDesignFullRank(X, C, strategy = "correlation") + expect_true(is.matrix(result)) + expect_equal(nrow(result), nrow(X)) + # Should produce full-rank design + full_design <- cbind(1, result, C) + expect_equal(qr(full_design)$rank, ncol(full_design)) +}) + +# --- filterVariantsByLdReference ----------------------------------------- + +test_that("filterVariantsByLdReference filters via a PLINK metadata file", { + skip_if_not_installed("pgenlibr") + geno <- loadTestGenotype() + vi <- geno$variant_info + variant_ids <- paste0(vi$chrom, ":", vi$pos, ":", vi$A2, ":", vi$A1) + fake_ids <- c("21:999999:A:G", "21:888888:C:T") + all_ids <- c(variant_ids, fake_ids) + + # Create a metadata TSV in the same directory as the PLINK files + # so the relative path resolves correctly + meta_file <- file.path(test_data_dir, "ld_meta_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 <- suppressMessages( + filterVariantsByLdReference(all_ids, meta_file, keepIndel = TRUE) + ) + expect_true(is.list(result)) + expect_true(length(result$data) <= length(all_ids)) + expect_true(length(result$idx) == length(result$data)) + # Fake variants should be filtered out + expect_true(length(result$data) <= length(variant_ids)) +}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index a34b44f8..9bbfcf94 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -14,8 +14,11 @@ ) } +# Read once and shared: the panel is a value, and some forty tests take one. +.toyLdRefPanel <- readGenotypes(plink1Prefix = .toyRefPrefix()) + .toyLdRef <- function() { - readGenotypes(plink1Prefix = .toyRefPrefix()) + .toyLdRefPanel } # A small GWAS sumstats data.frame over real toy_ref chr22 variants. @@ -200,7 +203,7 @@ test_that("loadGwasSumStatsFromManifest builds from a data.frame manifest", { c("SNP", "A1", "A2", "Z", "N") %in% colnames(S4Vectors::mcols(obj[[1L]])) )) - expect_equal(length(qcInfo(obj)), 0L) # loaders run no QC + expect_equal(length(qcOptions(obj)), 0L) # loaders run no QC }) test_that("loadGwasSumStatsFromManifest reads a file and reconciles genome", { @@ -262,22 +265,27 @@ test_that("tabix-indexed text honours the region", { tsv <- .writeSumstatsTsv(.toyGwasDf(5), file.path(tmp, "s.tsv")) gz <- Rsamtools::bgzip(tsv, dest = paste0(tsv, ".gz"), overwrite = TRUE) Rsamtools::indexTabix(gz, seq = 1L, start = 2L, end = 2L, comment = "#") - df <- pecotmr:::.readSumStatsText(gz, "22:14560000-14565000", NULL, "lbl") + df <- pecotmr:::.readSumStatsText( + gz, + GenomicRanges::GRanges("22:14560000-14565000"), + NULL, + "lbl" + ) expect_equal(nrow(df), 2L) # first two variants only expect_true(all(df$pos >= 14560000 & df$pos <= 14565000)) }) -test_that("plain-text region is ignored with a warning", { +test_that("plain text cannot narrow a read to the region", { tmp <- withr::local_tempdir() tsv <- .writeSumstatsTsv(.toyGwasDf(5), file.path(tmp, "s.tsv")) expect_warning( df <- pecotmr:::.readSumStatsText( tsv, - "22:14560000-14565000", + GenomicRanges::GRanges("22:14560000-14565000"), NULL, "lbl" ), - "region ignored" + "the whole file is read" ) expect_equal(nrow(df), 5L) }) @@ -382,6 +390,48 @@ test_that(".resolveSumstatCols derives the Wald z from beta/se", { expect_true(all(c("BETA", "SE") %in% colnames(out))) # beta/se still attached }) +test_that("an af: key is directional AF; a maf: key is directionless", { + # Same source column, different declaration -> different meaning. + a <- suppressWarnings(.resolveSumstatCols( + .afm_df("effect_allele_frequency", 0.8), + .afm_cm(af = "effect_allele_frequency"), + "af" + )) + expect_equal(a$AF, 0.8) + expect_false("MAF" %in% names(a)) + b <- suppressWarnings(.resolveSumstatCols( + .afm_df("effect_allele_frequency", 0.8), + .afm_cm(maf = "effect_allele_frequency"), + "maf" + )) + expect_false("AF" %in% names(b)) + expect_equal(b$MAF, 0.8) +}) + +test_that("an undeclared af warns distinctly and yields no AF column", { + expect_warning( + out <- .resolveSumstatCols( + .afm_df("maf", 0.2), + .afm_cm(maf = "maf"), + "undeclared" + ), + "no effect-allele frequency declared" + ) + expect_false("AF" %in% names(out)) +}) + +test_that("a declared-but-unusable af warns with a different message", { + # Distinct from "undeclared": this is a data problem, not a mapping one. + expect_warning( + .resolveSumstatCols( + .afm_df("eaf", NA_real_), + .afm_cm(af = "eaf"), + "missing" + ), + "declared but its values are all missing" + ) +}) + test_that(".resolveSumstatCols keeps a supplied z over beta/se", { df <- .toyGwasDf(4) df$beta <- rep(99, 4) @@ -748,6 +798,42 @@ test_that("loadQtlSumStatsFromManifest errors when a tuple has no N source", { path } +test_that("a phenotype BED's chromosomes are read in UCSC style", { + tmp <- withr::local_tempdir() + path <- file.path(tmp, "ncbi.bed") + readr::write_tsv( + data.frame( + `#chr` = c("22", "MT"), + start = c(10L, 20L), + end = c(11L, 21L), + gene_id = c("gA", "gB"), + S1 = c(1, 2), + check.names = FALSE + ), + path + ) + rr <- pecotmr:::.readPhenotypeBed(path)$rr + expect_identical( + as.character(GenomicRanges::seqnames(rr)), + c("chr22", "chrM") + ) + expect_identical(GenomeInfoDb::seqlevelsStyle(rr), "UCSC") +}) + +test_that("a manifest's BED-style ranges are read in UCSC style", { + df <- data.frame( + chrom = c("22", "chrX"), + start = c(0L, 10L), + end = c(5L, 20L) + ) + gr <- pecotmr:::.manifestRanges(df, "start", "end", "QTL", "window") + expect_identical( + as.character(GenomicRanges::seqnames(gr)), + c("chr22", "chrX") + ) + expect_identical(GenomicRanges::start(gr), c(1L, 11L)) +}) + test_that("loadQtlDatasetFromManifest builds a single-study dataset", { tmp <- withr::local_tempdir() bed <- .writePhenoBed(file.path(tmp, "ctxA.bed")) @@ -799,7 +885,7 @@ test_that("loadMultiStudyQtlDatasetFromManifest builds from >=2 studies", { msd <- loadMultiStudyQtlDatasetFromManifest(manifest) expect_s4_class(msd, "MultiStudyQtlDataset") expect_true(methods::validObject(msd)) - expect_equal(sort(names(qtlDatasets(msd))), c("study1", "study2")) + expect_equal(sort(names(msd)), c("study1", "study2")) }) test_that("loadMultiStudyQtlDatasetFromManifest attaches a summary study", { @@ -828,7 +914,7 @@ test_that("loadMultiStudyQtlDatasetFromManifest attaches a summary study", { ) expect_true(methods::validObject(msd)) expect_s4_class(msd@sumStats, "QtlSumStats") - expect_equal(names(qtlDatasets(msd)), "study1") + expect_equal(names(msd), "study1") }) # =========================================================================== @@ -905,7 +991,7 @@ test_that(".readGenotypePath reads a VCF as a panel", { 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_true("chr22" %in% names(pecotmr:::.ldRefChromPaths(sharded))) expect_s4_class( pecotmr:::.resolveLdRef(.toyRefPrefix()), "RangedSummarizedExperiment" @@ -934,12 +1020,12 @@ test_that(".materializeLdRef and .resolveGenotypes take a panel too", { ) }) -test_that(".entriesChroms collects canonical chromosomes across entries", { +test_that(".entriesChroms collects the chromosomes across entries", { a <- pecotmr:::.dfToEntryGranges(.toyGwasDf(3)) # chr22 b <- .toyGwasDf(2) b$chrom <- "1" b <- pecotmr:::.dfToEntryGranges(b) - expect_setequal(pecotmr:::.entriesChroms(list(a, b)), c("22", "1")) + expect_setequal(pecotmr:::.entriesChroms(list(a, b)), c("chr22", "chr1")) expect_equal(pecotmr:::.entriesChroms(list()), character(0)) expect_equal(pecotmr:::.entriesChroms(list(NULL)), character(0)) }) @@ -954,7 +1040,7 @@ test_that(".materializeLdRef passes a handle through, restricts shards", { spec <- c("22" = .toyRefPrefix(), "21" = "/no/such/chr21/prefix") restricted <- pecotmr:::.materializeLdRef(spec, "22") expect_s4_class(restricted, "RangedSummarizedExperiment") - expect_equal(names(pecotmr:::.ldRefChromPaths(restricted)), "22") + expect_equal(names(pecotmr:::.ldRefChromPaths(restricted)), "chr22") expect_error(pecotmr:::.materializeLdRef(spec, c("22", "21"))) }) @@ -1036,7 +1122,7 @@ test_that(".checkLdContainment warns when the sketch has no variant metadata", { nSamples = 0L, sampleIds = character(), pgenPtr = NULL, - chromPaths = c("22" = "/p") + chromPaths = c(chr22 = "/p") ) gr <- pecotmr:::.dfToEntryGranges(.toyGwasDf(3)) expect_warning( @@ -1049,21 +1135,6 @@ test_that(".checkLdContainment warns when the sketch has no variant metadata", { # Coverage: region coercion and column-mapping errors # =========================================================================== -test_that(".asGRegion coerces strings, GRanges, and data.frames", { - gr <- GenomicRanges::GRanges("22", IRanges::IRanges(1, 100)) - expect_identical(pecotmr:::.asGRegion(gr), gr) - fromStr <- pecotmr:::.asGRegion("22:1-100") - expect_equal(GenomicRanges::start(fromStr), 1L) - fromDf <- pecotmr:::.asGRegion(data.frame( - chrom = "22", - start = 1, - end = 100 - )) - expect_equal(as.character(GenomicRanges::seqnames(fromDf)), "22") - expect_error(pecotmr:::.asGRegion("not-a-region"), "chr:start-end") - expect_error(pecotmr:::.asGRegion(42L), "chr:start-end") -}) - test_that(".readColumnMapping errors on bad inputs", { tmp <- withr::local_tempdir() expect_error( @@ -1132,7 +1203,7 @@ test_that("loadQtlSumStatsFromManifest attaches varY and honours region", { manifest, genome = "hg38", ldReference = .toyLdRef(), - region = data.frame(chrom = "22", start = 1, end = 5e7) + which = GenomicRanges::GRanges("22:1-50000000") )) expect_equal(as.numeric(obj$varY), 1.7) }) @@ -1247,7 +1318,8 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { samples = "study1", n = 5, dropSs = FALSE, - dropEs = FALSE + dropEs = FALSE, + reference = NULL ) { pos <- c(14560203, 14564328, 14850625, 14870204, 14878387)[seq_len(n)] ids <- c( @@ -1274,6 +1346,7 @@ test_that("QtlDataset builder errors on inconsistent per-context paths", { ) meta <- c( "##fileformat=VCFv4.2", + if (!is.null(reference)) str_c("##reference=", reference), unname(hdrFor[tags]), "##contig=", paste( @@ -1350,6 +1423,54 @@ test_that("loadGwasSumStatsFromManifest reads a GWAS-VCF (A1=ALT, Z=ES/SE)", { expect_equal(mc$N, rep(10000, 5)) }) +test_that("a GWAS-VCF's recorded build stands in for a missing genome", { + skip_if_not_installed("VariantAnnotation") + tmp <- withr::local_tempdir() + vcf <- .writeGwasVcf(file.path(tmp, "study1.vcf"), reference = "hg38") + manifest <- data.frame(study = "study1", sumStatsPath = vcf) + obj <- suppressWarnings( + loadGwasSumStatsFromManifest(manifest, ldReference = .toyLdRef()) + ) + expect_equal(unique(unname(GenomeInfoDb::genome(obj))), "hg38") + # A build that contradicts the file's is refused, not taken. + expect_error( + suppressWarnings(loadGwasSumStatsFromManifest( + manifest, + genome = "hg19", + ldReference = .toyLdRef() + )), + "`genome` is 'hg19', but the GWAS-VCF files record 'hg38'" + ) +}) + +test_that("the given build and the VCFs' recorded ones reconcile", { + f <- pecotmr:::.manifestBuild + expect_equal(f("hg38", character(0), "f"), "hg38") + expect_equal(f("hg38", "hg38", "f"), "hg38") + expect_error( + f(NULL, c("hg19", "hg38"), "f"), + "record different genome builds \\(hg19, hg38\\)" + ) + expect_error(f(NULL, character(0), "f"), "`genome` must be provided") +}) + +test_that("only a manifest's VCF paths are read for a build", { + skip_if_not_installed("VariantAnnotation") + tmp <- withr::local_tempdir() + df <- data.frame( + sumStatsPath = c( + .writeGwasVcf(file.path(tmp, "a.vcf"), reference = "hg38"), + .writeGwasVcf(file.path(tmp, "b.vcf")), + file.path(tmp, "c.tsv") + ) + ) + expect_equal(pecotmr:::.manifestVcfBuilds(df, tmp), "hg38") + expect_equal( + pecotmr:::.manifestVcfBuilds(df[3L, , drop = FALSE], tmp), + character(0) + ) +}) + test_that("GWAS-VCF sample selection is enforced for multi-sample files", { skip_if_not_installed("VariantAnnotation") tmp <- withr::local_tempdir() @@ -1388,23 +1509,65 @@ test_that("GWAS-VCF sample selection is enforced for multi-sample files", { ) }) -test_that("GWAS-VCF without SS errors", { +test_that("GWAS-VCF without SS, or without ES/SE, errors", { skip_if_not_installed("VariantAnnotation") tmp <- withr::local_tempdir() - vcf <- .writeGwasVcf(file.path(tmp, "noss.vcf"), dropSs = TRUE) - manifest <- data.frame( - study = "study1", - sumStatsPath = vcf, - stringsAsFactors = FALSE - ) - expect_error( - suppressWarnings(loadGwasSumStatsFromManifest( - manifest, - genome = "hg38", - ldReference = .toyLdRef() - )), - "SS" - ) + # Each case drops fields the reader needs; the error names them. + cases <- list(SS = list(dropSs = TRUE), `ES and SE` = list(dropEs = TRUE)) + for (field in names(cases)) { + vcf <- exec( + .writeGwasVcf, + tempfile(tmpdir = tmp, fileext = ".vcf"), + !!!cases[[field]] + ) + manifest <- data.frame( + study = "study1", + sumStatsPath = vcf, + stringsAsFactors = FALSE + ) + expect_error( + suppressWarnings(loadGwasSumStatsFromManifest( + manifest, + genome = "hg38", + ldReference = .toyLdRef() + )), + field, + info = field + ) + } +}) + +# Drop the ES and SE subfields from one record (or leave a header line as-is). +# @noRd +.ezDropEsSe <- function(line) { + if (!str_starts(line, "chr1")) { + return(line) + } + fields <- str_split(line, "\t")[[1L]] + keys <- str_split(fields[[9L]], ":")[[1L]] + values <- str_split(fields[[10L]], ":")[[1L]] + keep <- !is_in(keys, c("ES", "SE")) + fields[[9L]] <- str_flatten(keys[keep], ":") + fields[[10L]] <- str_flatten(values[keep], ":") + str_flatten(fields, "\t") +} + +test_that("a z-only GWAS-VCF reads without ES and SE", { + # Reading EZ was missing altogether, so a file whose ES/SE were derived + # upstream from z either lost that fact or, with no ES/SE at all, was + # refused outright. + skip_if_not_installed("VariantAnnotation") + out <- withr::local_tempfile(fileext = ".vcf") + writeGwasVcf(.ezss(TRUE), out) + lines <- readLines(out) + lines <- lines[!str_detect(lines, "^##FORMAT== 0" + "unused argument" ) + expect_error(GenotypeFilterParam(mafCutoff = -1), "mafCutoff.*is not >= 0") expect_error( - loadQtlDatasetFromManifest( - data.frame(), - genotypeFilterParam = GenotypeFilterParam(keepIndel = NA) - ), + GenotypeFilterParam(keepIndel = NA), "keepIndel.*May not be NA" ) - # A bare list cannot be checked, so it is refused outright. expect_error( - loadQtlDatasetFromManifest( - data.frame(), - genotypeFilterParam = list(mafCutoff = 0.01) - ), - "must be built with GenotypeFilterParam" + GenotypeFilterParam(xvarCutoff = -1), + "xvarCutoff.*is not >= 0" ) + # A bare list cannot be checked, so a run refuses it outright. expect_error( - loadQtlDatasetFromManifest( - data.frame(), - scaleResiduals = c(TRUE, TRUE) - ), - "scaleResiduals.*Must have length 1" + pecotmr:::.qtlResolveFilter(list(mafCutoff = 0.01)), + "must be built with GenotypeFilterParam" ) expect_error( loadQtlDatasetFromManifest(data.frame(), studyName = 1L), @@ -1840,13 +2067,6 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { ), "minLdOverlapWarn.*is not <= 1" ) - expect_error( - loadMultiStudyQtlDatasetFromManifest( - data.frame(), - genotypeFilterParam = GenotypeFilterParam(xvarCutoff = -1) - ), - "xvarCutoff.*is not >= 0" - ) }) # --------------------------------------------------------------------------- @@ -1889,7 +2109,7 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { test_that("a directional AF survives the GWAS-VCF round trip", { skip_if_not_installed("VariantAnnotation") out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(.afvcf_sumstats(), out) + writeGwasVcf(.afvcf_sumstats(), out) back <- .readSumStatsVcf(out, NULL, NULL, NULL, "x") # Unfolded, and under its own name -- 0.8 is an ALT frequency above 0.5, # which is exactly the case folding destroys. @@ -1902,7 +2122,7 @@ test_that("a directional AF survives the GWAS-VCF round trip", { test_that("a GWAS-VCF with no AF has neither AF nor a folded one", { skip_if_not_installed("VariantAnnotation") out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(.afvcf_sumstats(af = NULL), out) + writeGwasVcf(.afvcf_sumstats(af = NULL), out) back <- .readSumStatsVcf(out, NULL, NULL, NULL, "x") expect_false(is_in("AF", names(back))) expect_false(is_in("MAF", names(back))) @@ -1911,7 +2131,7 @@ test_that("a GWAS-VCF with no AF has neither AF nor a folded one", { test_that("an explicit formatMapping still redirects the AF slot", { skip_if_not_installed("VariantAnnotation") out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(.afvcf_sumstats(), out) + writeGwasVcf(.afvcf_sumstats(), out) # Reading the spec's AF field into the MAF slot on purpose: the caller # says this file's AF is not to be trusted as directional. back <- .readSumStatsVcf( @@ -1924,3 +2144,108 @@ test_that("an explicit formatMapping still redirects the AF slot", { expect_false(is_in("AF", names(back))) expect_equal(as.numeric(back$MAF), c(0.2, 0.3)) }) + +test_that("a manifest's BED-style columns give each row its window", { + gwasTsv <- system.file( + "extdata", + "manifests", + "protocol_example.twas.gwas_sumstats.chr22.tsv.gz", + package = "pecotmr" + ) + ldStem <- file.path( + system.file("extdata", "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22" + ) + mf <- data.frame( + study = "g1", + sumStatsPath = gwasTsv, + chrom = "chr22", + start = 9999999L, + end = 19000000L + ) + g <- suppressWarnings(loadGwasSumStatsFromManifest( + manifest = mf, + genome = "hg38", + ldReference = ldStem + )) + # The start is 0-based, as in BED. + expect_identical(as.character(g$region), "chr22:10000000-19000000") + expect_true(g$regionGiven) + expect_error( + loadGwasSumStatsFromManifest( + manifest = mf, + genome = "hg38", + ldReference = ldStem, + which = GenomicRanges::GRanges("chr22:1-2") + ), + "cannot give them too" + ) + # A QTL row may also give its trait's position, on its `chrom`. + qmf <- data.frame( + study = "s1", + context = "c", + trait = "t", + sumStatsPath = gwasTsv, + chrom = "chr22", + start = 9999999L, + end = 19000000L, + traitStart = 15527999L, + traitEnd = 15528000L + ) + q <- suppressWarnings(loadQtlSumStatsFromManifest( + manifest = qmf, + genome = "hg38", + ldReference = ldStem + )) + expect_identical(as.character(q$region), "chr22:10000000-19000000") + expect_true(q$regionGiven) + expect_identical(as.character(q$traitPos), "chr22:15528000") + # A QTL tuple has one window. + expect_error( + loadQtlSumStatsFromManifest( + manifest = qmf[, 1:4], + genome = "hg38", + ldReference = ldStem, + which = GenomicRanges::GRanges(c("chr22:1-10", "chr22:20-30")) + ), + "must be one window" + ) + # A window needs all three columns, on every row. + expect_error( + loadGwasSumStatsFromManifest( + manifest = mf[, c("study", "sumStatsPath", "start", "end")], + genome = "hg38", + ldReference = ldStem + ), + "missing chrom" + ) + holes <- rbind( + mf, + data.frame( + study = "g2", + sumStatsPath = gwasTsv, + chrom = "chr22", + start = NA, + end = 19000000L + ) + ) + expect_error( + loadGwasSumStatsFromManifest( + manifest = holes, + genome = "hg38", + ldReference = ldStem + ), + "row(s) 2 leave their window empty", + fixed = TRUE + ) +}) + +test_that(".matchRegionSeqnames reads the windows a file holds, once", { + gr <- GenomicRanges::GRanges( + c("chr22", "chr22", "chr3"), + IRanges::IRanges(c(1L, 50L, 1L), c(100L, 200L, 10L)) + ) + m <- pecotmr:::.matchRegionSeqnames(gr, c("22", "21")) + expect_identical(as.character(m), "22:1-200") + expect_null(pecotmr:::.matchRegionSeqnames(gr[3L], "22")) +}) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 868f8f68..b5897921 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -1,8 +1,7 @@ # ============================================================================= -# Tests for utility helpers exported from R/mashPipeline.R that don't -# require mashr / flashier installs: -# sanitizeMashData, makePairwiseContrastCol, sliceMashData, -# metaAnalysisPerCondition +# Tests for R/mashPipeline.R: the mash pipeline and its extracted building +# blocks, the contrast and feature-score helpers, and the input preparation +# that turns SumStats / fine-mapping objects into mash matrices. # Fixtures for the input-preparation tests, moved here with them. @@ -20,7 +19,7 @@ format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(nSnp)), - CHR = "1", + CHR = "chr1", BP = seq(100L, by = 100L, length.out = nSnp), A1 = "A", A2 = "G", @@ -49,7 +48,7 @@ entry = entries, genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) } @@ -60,7 +59,7 @@ format = "plink2", snpInfo = data.frame( SNP = "chr1:100:A:G", - CHR = "1", + CHR = "chr1", BP = 100L, A1 = "A", A2 = "G", @@ -123,12 +122,12 @@ ) } vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") - e1 <- fineMappingRow( + e1 <- FineMappingRow( variantIds = vids, susieFit = list(x = 1), topLoci = mkTL(c(0.5, -1, 6.0, 0.2, 1.1, -0.3), c(3, 2)) ) - e2 <- fineMappingRow( + e2 <- FineMappingRow( variantIds = vids, susieFit = list(x = 1), topLoci = mkTL(c(-0.4, 0.7, 0.1, 5.0, -1.2, 0.6), c(4, 5)) @@ -142,6 +141,71 @@ ) } +# The mash fixture and the fits several tests only read, each built on first +# use and then shared. Every mash() call forces three garbage collections +# (mashr times each step with system.time()), which costs far more than the +# fit itself, so repeated fits are what made this file slow. +delayedAssign(".mpSs", mashFixture()) +# The default component set, and the default prior refined from it. +delayedAssign( + ".mpDefaultComps", + suppressMessages(suppressWarnings(mashCovarianceComponents( + list(strong = .mpSs), + alpha = 0, + vhat = diag(3), + nPcs = 2L, + setSeed = 1L + ))) +) +delayedAssign( + ".mpDefaultPrior", + suppressMessages(suppressWarnings(mashPriorCovariances( + list(strong = .mpSs), + alpha = 0, + vhat = diag(3), + nPcs = 2L, + setSeed = 1L + ))) +) +# The whole pipeline: null-based Vhat, then the default prior chain. +delayedAssign( + ".mpSimpleFull", + suppressMessages(suppressWarnings(mashPipeline( + list(strong = .mpSs, random = .mpSs, null = .mpSs), + alpha = 0, + residualCorrelationMethod = "simple", + setSeed = 1L + ))) +) +# mashPipeline with the tiny prior under each residual-correlation setup the +# residualCorrelationMethod tests compare. evaluate_promise() keeps the +# messages a run emits next to its result. +.mpVhatRun <- function(partitions, ...) { + evaluate_promise(mashPipeline( + set_names(rep(list(.mpSs), length(partitions)), partitions), + alpha = 0, + ..., + prior = MashPriorParam(priorCovariances = mashTinyPrior()), + setSeed = 1L + )) +} +delayedAssign(".mpVhatWithNull", .mpVhatRun(c("strong", "random", "null"))) +delayedAssign(".mpVhatWithoutNull", .mpVhatRun(c("strong", "random"))) +delayedAssign( + ".mpVhatIdentity", + .mpVhatRun( + c("strong", "random", "null"), + residualCorrelationMethod = "identity" + ) +) +delayedAssign( + ".mpVhatSimple", + .mpVhatRun( + c("strong", "random", "null"), + residualCorrelationMethod = "simple" + ) +) + # ============================================================================= # --------------------------------------------------------------------------- @@ -471,7 +535,7 @@ test_that("fitMashContrast: 3-tested-conditions yields deviation + pairwise cont test_that("mashPipeline runs end-to-end on qtlSumStatsMulticontextExample", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs # Use the same fixture for strong/random; nPcs <= ncol - 1 (3 contexts). res <- suppressMessages(suppressWarnings( mashPipeline( @@ -631,7 +695,7 @@ test_that("mashPipeline coerces a SimpleList before validating its names", { test_that("mashPipeline rejects priorCovariances not a non-empty named list", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs vhat <- diag(3) # Empty list. expect_error( @@ -662,7 +726,7 @@ test_that("mashPipeline rejects priorCovariances not a non-empty named list", { test_that("mashPipeline rejects priorCovariances with wrong dimensions", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs vhat <- diag(3) expect_error( suppressMessages(suppressWarnings( @@ -680,7 +744,7 @@ test_that("mashPipeline rejects priorCovariances with wrong dimensions", { test_that("mashPipeline passes supplied residualCorrelation + priorCovariances through", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs vhat <- diag(3) U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) res <- suppressMessages(suppressWarnings( @@ -706,18 +770,10 @@ test_that("mashPipeline passes supplied residualCorrelation + priorCovariances t test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() # `residualCorrelationMethod = "simple"` runs # estimate_null_correlation_simple on the null set; leaving nPcs NULL # exercises the `nPcs <- ncol(Bhat) - 1` default in the cov_* chain. - res <- suppressMessages(suppressWarnings( - mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - residualCorrelationMethod = "simple", - setSeed = 1L - ) - )) + res <- .mpSimpleFull expect_named(res, c("U", "w")) expect_gt(length(res$U), 0L) expect_true(all(map_lgl( @@ -738,116 +794,46 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { test_that("the default is identity regardless of which partitions are given", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - prior <- mashTinyPrior() # The default must not depend on data shape -- that was the old silent # behaviour this argument replaced. `w` is what carries the evidence: it # is fitted against V, so an identical `w` across the three calls is the # same V reaching mash() each time. (`U` is the supplied prior passed # through, so comparing it would prove nothing here.) - withNull <- suppressMessages(suppressWarnings(mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - prior = MashPriorParam(priorCovariances = prior), - setSeed = 1L - ))) - withoutNull <- suppressMessages(suppressWarnings(mashPipeline( - list(strong = ss, random = ss), - alpha = 0, - prior = MashPriorParam(priorCovariances = prior), - setSeed = 1L - ))) - explicit <- suppressMessages(suppressWarnings(mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - residualCorrelationMethod = "identity", - prior = MashPriorParam(priorCovariances = prior), - setSeed = 1L - ))) - expect_equal(withNull$w, withoutNull$w) - expect_equal(withNull$w, explicit$w) + withNull <- .mpVhatWithNull$result + expect_equal(withNull$w, .mpVhatWithoutNull$result$w) + expect_equal(withNull$w, .mpVhatIdentity$result$w) }) test_that("an unused null partition is reported", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() # Assembling a null set and still getting identity is more often an # oversight than an intent, so it must not pass silently. - expect_message( - suppressWarnings(mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - prior = MashPriorParam(priorCovariances = mashTinyPrior()), - setSeed = 1L - )), - "does not use it" - ) + expect_match(.mpVhatWithNull$messages, "does not use it", all = FALSE) # Naming identity explicitly does not change that the set is unused. - expect_message( - suppressWarnings(mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - residualCorrelationMethod = "identity", - prior = MashPriorParam(priorCovariances = mashTinyPrior()), - setSeed = 1L - )), - "'null' partition" - ) + expect_match(.mpVhatIdentity$messages, "'null' partition", all = FALSE) }) test_that("no unused-null notice when there is nothing to ignore", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - noNull <- function() { - suppressWarnings(mashPipeline( - list(strong = ss, random = ss), - alpha = 0, - prior = MashPriorParam(priorCovariances = mashTinyPrior()), - setSeed = 1L - )) - } - expect_no_message(noNull(), message = "'null' partition") + expect_false(any(grepl("'null' partition", .mpVhatWithoutNull$messages))) # Nor when the null set is actually being consumed. - usesNull <- function() { - suppressWarnings(mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - residualCorrelationMethod = "simple", - prior = MashPriorParam(priorCovariances = mashTinyPrior()), - setSeed = 1L - )) - } - expect_no_message(usesNull(), message = "does not use it") + expect_false(any(grepl("does not use it", .mpVhatSimple$messages))) }) test_that("mashPipeline honours a data-driven residualCorrelationMethod", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - sl <- list(strong = ss, random = ss, null = ss) - prior <- mashTinyPrior() - identityFit <- suppressMessages(suppressWarnings(mashPipeline( - sl, - alpha = 0, - residualCorrelationMethod = "identity", - prior = MashPriorParam(priorCovariances = prior), - setSeed = 1L - ))) - simpleFit <- suppressMessages(suppressWarnings(mashPipeline( - sl, - alpha = 0, - residualCorrelationMethod = "simple", - prior = MashPriorParam(priorCovariances = prior), - setSeed = 1L - ))) # A different V has to move the fit, or the argument is not reaching it. - expect_false(isTRUE(all.equal(identityFit$w, simpleFit$w))) + expect_false(isTRUE(all.equal( + .mpVhatIdentity$result$w, + .mpVhatSimple$result$w + ))) }) test_that("mashPipeline rejects an unknown residualCorrelationMethod", { - ss <- mashFixture() + ss <- .mpSs expect_error( mashPipeline( list(strong = ss, random = ss), @@ -860,7 +846,7 @@ test_that("mashPipeline rejects an unknown residualCorrelationMethod", { test_that("a method needing a partition it lacks errors through mashPipeline", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs expect_error( mashPipeline( list(strong = ss, random = ss), @@ -874,7 +860,7 @@ test_that("a method needing a partition it lacks errors through mashPipeline", { test_that("a supplied residualCorrelation wins over the method", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs # 'simple' would error without a null set; the supplied matrix means the # estimator is never consulted. res <- suppressMessages(suppressWarnings(mashPipeline( @@ -894,7 +880,7 @@ test_that("a supplied residualCorrelation wins over the method", { test_that("mashResidualCorrelation(identity) is an identity of the right size", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs v <- mashResidualCorrelation( list(strong = ss), alpha = 0, @@ -906,7 +892,7 @@ test_that("mashResidualCorrelation(identity) is an identity of the right size", test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -921,7 +907,7 @@ test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { test_that("mashResidualCorrelation(simple) errors without a null entry", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs expect_error( mashResidualCorrelation( list(strong = ss), @@ -934,7 +920,7 @@ test_that("mashResidualCorrelation(simple) errors without a null entry", { test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -949,7 +935,7 @@ test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", { skip_if_not_installed("mashr") skip_if_not_installed("CorShrink") - ss <- mashFixture() + ss <- .mpSs v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, null = ss), @@ -963,7 +949,7 @@ test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs v <- suppressMessages(suppressWarnings( mashResidualCorrelation( list(strong = ss, random = ss), @@ -971,7 +957,8 @@ test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { method = "mle", priorCovariances = list(identity = diag(3)), nSubset = 100L, - maxIter = 3L, + # One EM refinement: each iteration is another mash() fit. + maxIter = 1L, setSeed = 1L ) )) @@ -980,7 +967,7 @@ test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { test_that("mashResidualCorrelation errors when a method's inputs are missing", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs expect_error( mashResidualCorrelation( list(strong = ss), @@ -1008,16 +995,7 @@ test_that("mashResidualCorrelation errors when a method's inputs are missing", { test_that("mashPriorCovariances computes the default (all-but-udr) prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - pc <- suppressMessages(suppressWarnings( - mashPriorCovariances( - list(strong = ss), - alpha = 0, - vhat = diag(3), - nPcs = 2L, - setSeed = 1L - ) - )) + pc <- .mpDefaultPrior expect_named(pc, c("U", "w", "loglik")) expect_gt(length(pc$U), 0L) expect_true(all(map_lgl( @@ -1028,10 +1006,10 @@ test_that("mashPriorCovariances computes the default (all-but-udr) prior", { expect_null(pc$loglik) }) -test_that("mashPriorCovariances passes a supplied prior through unchanged", { +test_that("mashPriorCovariances passes a given prior through, either shape", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) pc <- suppressMessages(suppressWarnings( mashPriorCovariances( @@ -1043,12 +1021,24 @@ test_that("mashPriorCovariances passes a supplied prior through unchanged", { )) expect_identical(pc$U, U0) expect_equal(sum(pc$w), 1, tolerance = 1e-6) + # A mashPriorCovariances()-shaped list(U, w, loglik) is unwrapped to the + # same prior and fits the same weights. + wrapped <- suppressMessages(suppressWarnings( + mashPriorCovariances( + list(strong = ss), + alpha = 0, + vhat = diag(3), + priorCovariances = list(U = U0, w = NULL, loglik = NULL) + ) + )) + expect_equal(names(wrapped$U), names(pc$U)) + expect_equal(wrapped$w, pc$w) }) test_that("mashPriorCovariances validates a supplied prior", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( @@ -1076,7 +1066,7 @@ test_that("mashPriorCovariances validates a supplied prior", { test_that("mashPriorCovariances(flashNonneg) adds components vs flash-only", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs base <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -1087,28 +1077,24 @@ test_that("mashPriorCovariances(flashNonneg) adds components vs flash-only", { setSeed = 1L ) )) - wide <- suppressMessages(suppressWarnings( - mashPriorCovariances( - list(strong = ss), - alpha = 0, - vhat = diag(3), - components = c("canonical", "pca", "flash", "flashNonneg"), - nPcs = 2L, - setSeed = 1L - ) - )) - expect_gt(length(wide$U), length(base$U)) + # The shared default prior is this same call with flashNonneg added. + expect_identical( + eval(formals(mashPriorCovariances)$components), + c("canonical", "pca", "flash", "flashNonneg") + ) + expect_gt(length(.mpDefaultPrior$U), length(base$U)) }) test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") skip_if_not_installed("udr") - ss <- mashFixture() - # A toy-sized udr config: `n_unconstrained` dominates the cost, and the default - # (50, sized for many-condition data) is pathological on a 3-condition fixture - # (it drove a 5+ minute fit). 2 unconstrained matrices suffice to exercise the - # udr path. + ss <- .mpSs + # A toy-sized udr config: `n_unconstrained` dominates the cost, and the + # default (50, sized for many-condition data) is pathological on a + # 3-condition fixture (it drove a 5+ minute fit). 2 unconstrained + # matrices suffice to exercise the udr path, and on the beta scale each + # update iteration is slow, so a few iterations do too. pc <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -1116,7 +1102,7 @@ test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { vhat = diag(3), engine = CovUdrOptions( init = UdInitOptions(n_unconstrained = 2L), - fit = UdFitOptions(maxiter = 20L) + fit = UdFitOptions(maxiter = 5L) ), setSeed = 1L ) @@ -1129,11 +1115,33 @@ test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { expect_equal(sum(pc$w), 1, tolerance = 1e-6) }) +test_that("the udr engine runs on the z scale, where udr picks TED", { + skip_if_not_installed("mashr") + skip_if_not_installed("udr") + # The companion to the alpha = 0 udr run in test_mashPipeline.R: on the + # beta scale pecotmr pins the update, so only here does udr choose. + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances( + list(strong = .mwSs), + alpha = 1, + vhat = diag(3), + engine = CovUdrOptions( + init = UdInitOptions(n_unconstrained = 2L), + fit = UdFitOptions(maxiter = 20L) + ), + setSeed = 1L + ) + )) + expect_gt(length(pc$U), 0L) + expect_true(all(map_lgl(pc$U, function(m) all(dim(m) == c(3L, 3L))))) + expect_equal(sum(pc$w), 1, tolerance = 1e-6) +}) + test_that("mashPriorCovariances TED update errors clearly on non-i.i.d. data", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") skip_if_not_installed("udr") - ss <- mashFixture() + ss <- .mpSs expect_error( suppressMessages(suppressWarnings( mashPriorCovariances( @@ -1153,7 +1161,7 @@ test_that("mashPriorCovariances TED update errors clearly on non-i.i.d. data", { test_that("mashPriorCovariances rejects an unknown component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs expect_error( mashPriorCovariances( list(strong = ss), @@ -1172,7 +1180,7 @@ test_that("mashPriorCovariances rejects an unknown component", { test_that("mashCovarianceComponents builds a single requested component", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs fl <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1191,7 +1199,7 @@ test_that("mashCovarianceComponents builds a single requested component", { test_that("a requested component that yields nothing returns an empty list", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs # flashier legitimately finds no factors on weak data. c(NULL, NULL) is # NULL, so the collapse used to leak a NULL out of a function documented # to return a named list -- length()/names()/c() then behave differently @@ -1215,7 +1223,7 @@ test_that("a requested component that yields nothing returns an empty list", { test_that("mashCovarianceComponents default builds all non-udr components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs one <- suppressMessages(suppressWarnings( mashCovarianceComponents( list(strong = ss), @@ -1225,40 +1233,16 @@ test_that("mashCovarianceComponents default builds all non-udr components", { setSeed = 1L ) )) - all4 <- suppressMessages(suppressWarnings( - mashCovarianceComponents( - list(strong = ss), - alpha = 0, - vhat = diag(3), - nPcs = 2L, - setSeed = 1L - ) - )) - expect_gt(length(all4), length(one)) + expect_gt(length(.mpDefaultComps), length(one)) }) test_that("mashCovarianceComponents feeds mashPriorCovariances (same components)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - comps <- suppressMessages(suppressWarnings( - mashCovarianceComponents( - list(strong = ss), - alpha = 0, - vhat = diag(3), - nPcs = 2L, - setSeed = 1L - ) - )) - prior <- suppressMessages(suppressWarnings( - mashPriorCovariances( - list(strong = ss), - alpha = 0, - vhat = diag(3), - nPcs = 2L, - setSeed = 1L - ) - )) + ss <- .mpSs + # Both built with the same settings: the default components, nPcs = 2. + comps <- .mpDefaultComps + prior <- .mpDefaultPrior # Canonical components are structural hypotheses and reach the prior # unrefined, so their names survive verbatim. The data-driven ones are # replaced by their Extreme Deconvolution refinements (mashr names those @@ -1286,7 +1270,7 @@ test_that("mashCovarianceComponents feeds mashPriorCovariances (same components) test_that("mashCovarianceComponents rejects unknown components", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs expect_error( mashCovarianceComponents( list(strong = ss), @@ -1300,16 +1284,8 @@ test_that("mashCovarianceComponents rejects unknown components", { test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode)", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - comps <- suppressMessages(suppressWarnings( - mashCovarianceComponents( - list(strong = ss), - alpha = 0, - vhat = diag(3), - nPcs = 2L, - setSeed = 1L - ) - )) + ss <- .mpSs + comps <- .mpDefaultComps pr <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -1331,7 +1307,7 @@ test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode) test_that("mashPriorCovariances validates priorComponents", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs expect_error( mashPriorCovariances( list(strong = ss), @@ -1345,15 +1321,9 @@ test_that("mashPriorCovariances validates priorComponents", { test_that("mashPipeline result == composing the two extracted building blocks", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() - full <- suppressMessages(suppressWarnings( - mashPipeline( - list(strong = ss, random = ss, null = ss), - alpha = 0, - residualCorrelationMethod = "simple", - setSeed = 1L - ) - )) + ss <- .mpSs + # The pipeline on (strong, random, null) with Vhat method "simple". + full <- .mpSimpleFull # Same seed discipline mashPipeline uses: seed once, then delegate with # setSeed = NULL so the RNG stream stays continuous. set.seed(1L) @@ -1375,11 +1345,6 @@ test_that("mashPipeline result == composing the two extracted building blocks", expect_equal(full$w, prior$w) }) -# --------------------------------------------------------------------------- -# mashModelFit + mashPosterior — the fit -> posterior chain (mash_fit / -# mash_posterior). A tiny 2-component prior keeps these fast. -# --------------------------------------------------------------------------- - # --------------------------------------------------------------------------- # Prior-shape normalisation (.mashAsUlist) # @@ -1405,32 +1370,9 @@ test_that(".mashAsUlist does not mistake a covariance named U for the wrapper", expect_equal(pecotmr:::.mashAsUlist(ulist), ulist) }) -test_that("mashPriorCovariances accepts either shape for its two prior args", { - skip_if_not_installed("mashr") - ss <- mashFixture() - sl <- list(strong = ss, random = ss) - ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) - wrapped <- list(U = ulist, w = NULL, loglik = NULL) - - bare <- suppressMessages(suppressWarnings(mashPriorCovariances( - sl, - alpha = 0, - vhat = diag(3), - priorCovariances = ulist - ))) - wrap <- suppressMessages(suppressWarnings(mashPriorCovariances( - sl, - alpha = 0, - vhat = diag(3), - priorCovariances = wrapped - ))) - expect_equal(names(wrap$U), names(bare$U)) - expect_equal(wrap$w, bare$w) -}) - test_that("fitMashContrast consumes a mashPosterior result", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs post <- suppressMessages(suppressWarnings( mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) )) @@ -1443,60 +1385,9 @@ test_that("fitMashContrast consumes a mashPosterior result", { }) # --------------------------------------------------------------------------- -# .rmaMeta: thin metafor::rma adapter (DL default; REML/ML/... pass through) +# metaAnalysisPerCondition # --------------------------------------------------------------------------- -test_that(".rmaMeta: DL is the default and reshapes the metafor fit", { - set.seed(1) - m <- rnorm(6) - s <- abs(rnorm(6)) + 0.2 - expect_equal( - pecotmr:::.rmaMeta(m, s), - pecotmr:::.rmaMeta(m, s, method = "DL") - ) - out <- pecotmr:::.rmaMeta(m, s) - expect_true(all(c("mean", "se", "tau2", "I2", "Q") %in% names(out))) - expect_true(out$I2 >= 0 && out$I2 <= 1) # metafor's % rescaled to [0,1] -}) - -test_that(".rmaMeta: DL matches the closed-form DerSimonian-Laird", { - means <- c(0.5, 0.8, 0.3) - ses <- c(0.2, 0.3, 0.15) - res <- pecotmr:::.rmaMeta(means, ses) - wFe <- 1 / ses^2 - muFe <- sum(wFe * means) / sum(wFe) - Q <- sum(wFe * (means - muFe)^2) - tau2 <- max(0, (Q - 2) / (sum(wFe) - sum(wFe^2) / sum(wFe))) - wRe <- 1 / (ses^2 + tau2) - expect_equal(res$Q, Q, tolerance = 1e-6) - expect_equal(res$tau2, tau2, tolerance = 1e-6) - expect_equal(res$mean, sum(wRe * means) / sum(wRe), tolerance = 1e-6) - expect_equal(res$se, sqrt(1 / sum(wRe)), tolerance = 1e-6) -}) - -test_that(".rmaMeta: non-DL estimator (REML) runs via metafor and differs from DL", { - set.seed(3) - m <- rnorm(8, sd = 1.5) - s <- abs(rnorm(8)) + 0.3 - reml <- pecotmr:::.rmaMeta(m, s, method = "REML") - expect_true(all(c("mean", "se", "tau2", "I2", "Q") %in% names(reml))) - expect_true(reml$I2 >= 0 && reml$I2 <= 1) - # REML tau2 generally differs from DL tau2 on heterogeneous data - expect_false(isTRUE(all.equal(reml$tau2, pecotmr:::.rmaMeta(m, s)$tau2))) -}) - -test_that(".rmaMeta: non-DL estimator falls back to DL on non-convergence (never errors)", { - # metafor's iterative estimators can fail to converge on small / degenerate - # inputs; .rmaMeta must still return a finite fit (via the DL fallback). - set.seed(1) - for (i in seq_len(25)) { - m <- rnorm(sample(3:8, 1L)) - s <- abs(rnorm(length(m))) + 0.1 - r <- suppressWarnings(pecotmr:::.rmaMeta(m, s, method = "REML")) - expect_true(is.finite(r$mean) && is.finite(r$se)) - } -}) - test_that("metaAnalysisPerCondition: threads metaMethod (DL default unchanged)", { es <- matrix( rnorm(12), @@ -1707,7 +1598,7 @@ test_that("mashPosteriorContrast: empty frame when every feature is dropped", { test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs expect_error( mashResidualCorrelation(list(strong = ss), alpha = 0, method = "mle"), "requires a 'random' entry" @@ -1716,7 +1607,7 @@ test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs V <- suppressMessages(suppressWarnings( mashResidualCorrelation( S4Vectors::SimpleList(null = ss), @@ -1729,7 +1620,7 @@ test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs cc <- suppressMessages(suppressWarnings( mashCovarianceComponents( S4Vectors::SimpleList(strong = ss), @@ -1743,7 +1634,7 @@ test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { test_that("mashPriorCovariances: SimpleList input (canonical only)", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs pc <- suppressMessages(suppressWarnings( mashPriorCovariances( S4Vectors::SimpleList(strong = ss), @@ -1865,7 +1756,7 @@ test_that("MashPriorParam takes only a MashComponentParam for components", { test_that("mashPriorCovariances takes components as names or a record", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs byRecord <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -1884,7 +1775,7 @@ test_that("mashPriorCovariances takes components as names or a record", { test_that("engine 'none' leaves the data-driven components unrefined", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") - ss <- mashFixture() + ss <- .mpSs raw <- suppressMessages(suppressWarnings( mashPriorCovariances( list(strong = ss), @@ -1904,7 +1795,7 @@ test_that("engine 'none' leaves the data-driven components unrefined", { test_that("mashPriorCovariances rejects an unknown engine", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mpSs expect_error( mashPriorCovariances( list(strong = ss), @@ -2283,32 +2174,6 @@ test_that("filterInvalidSummaryStat z path handles NULL strong component", { expect_true(!is.null(result$random$z)) }) -test_that("filterMixtureComponents removes zero matrices", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 2), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - comp2 = matrix( - c(0, 0, 0, 0), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - A = matrix( - c(3, 0, 0, 4), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(comp1 = 0.5, comp2 = 0.3, A = 0.2) - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_false("comp2" %in% names(result$U)) -}) - test_that("filterMixtureComponents removes matrices below weight cutoff", { U <- list( comp1 = matrix( @@ -2344,29 +2209,7 @@ test_that("filterMixtureComponents errors on missing conditions", { ) }) -test_that("filterMixtureComponents removes components named as filtered conditions", { - U <- list( - comp1 = matrix( - c(1, 0, 0, 0, 2, 0, 0, 0, 3), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ), - C = matrix( - c(4, 0, 0, 0, 5, 0, 0, 0, 6), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ) - ) - w <- c(comp1 = 0.6, C = 0.4) - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_false("C" %in% names(result$U)) - expect_equal(nrow(result$U$comp1), 2) - expect_equal(ncol(result$U$comp1), 2) -}) - -test_that("filterMixtureComponents renormalizes weights to preserve original sum", { +test_that("filterMixtureComponents drops zero matrices, renormalizes weights", { U <- list( comp1 = matrix( c(1, 0, 0, 2), @@ -2551,28 +2394,6 @@ test_that("mergeMashData uses one_data when res_data element has zero rows", { expect_true(nrow(result$random) >= 3) }) -test_that("mashRandNullSample with z scores returns random and null", { - set.seed(42) - dat <- list( - z = data.frame( - cond1 = c(5, 0.1, 0.2, 0.3, 0.5, 6, 0.1, 0.2, 0.4, 0.3), - cond2 = c(0.2, 0.3, 0.1, 0.5, 0.4, 0.1, 0.3, 0.2, 0.1, 0.5) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 5, - nNull = 3, - excludeCondition = c(), - seed = 123 - ) - expect_type(result, "list") - expect_true("random" %in% names(result)) - expect_true("null" %in% names(result)) - expect_true("z" %in% names(result$random)) - expect_equal(nrow(result$random$z), 5) -}) - test_that("mashRandNullSample with seed is reproducible", { dat <- list( z = data.frame( @@ -2648,29 +2469,6 @@ test_that("mashRandNullSample warns when not enough null data", { expect_equal(length(result$null), 0) }) -test_that("mashRandNullSample with bhat/sbhat processes random and null samples", { - dat <- list( - bhat = data.frame( - cond1 = c(0.1, 0.05, 0.02, 0.01, 0.03), - cond2 = c(0.02, 0.01, 0.03, 0.05, 0.04) - ), - sbhat = data.frame( - cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 3, - nNull = 3, - excludeCondition = c(), - seed = 42 - ) - expect_equal(ncol(result$random$bhat), 2) - expect_equal(nrow(result$random$bhat), 3) - expect_true(length(result$null) > 0) -}) - test_that("mashRandNullSample errors when excludeCondition not found (z path)", { dat <- list( z = data.frame(cond1 = 1:5, cond2 = 1:5) @@ -2685,6 +2483,17 @@ test_that("mashRandNullSample errors when excludeCondition not found (z path)", ), "excludeCondition are not present" ) + # A numeric index is not a column name, even where it is a valid position. + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = 2, + seed = 42 + ), + "excludeCondition are not present" + ) }) test_that("mashRandNullSample errors when excludeCondition not found (bhat path)", { @@ -2702,6 +2511,17 @@ test_that("mashRandNullSample errors when excludeCondition not found (bhat path) ), "excludeCondition are not present" ) + # A numeric index is not a column name, even where it is a valid position. + expect_error( + mashRandNullSample( + dat, + nRandom = 3, + nNull = 2, + excludeCondition = 2, + seed = 42 + ), + "excludeCondition are not present" + ) }) test_that("mashRandNullSample drops excluded condition by column name", { @@ -2724,7 +2544,7 @@ test_that("mashRandNullSample drops excluded condition by column name", { expect_false("cond3" %in% colnames(result$random$z)) }) -test_that("mashRandNullSample extracts null data with z scores when enough null variants exist", { +test_that("mashRandNullSample draws random and null samples from z scores", { dat <- list( z = data.frame( cond1 = c(0.1, 0.3, 0.2, 0.5, 0.4, 0.1, 0.3, 0.2, 0.5, 0.4), @@ -2745,7 +2565,7 @@ test_that("mashRandNullSample extracts null data with z scores when enough null expect_equal(nrow(result$random$z), 5) }) -test_that("mashRandNullSample null data capped at available null variants", { +test_that("mashRandNullSample caps both samples at the available rows", { dat <- list( z = data.frame( cond1 = c(0.1, 0.2, 0.3), @@ -2754,16 +2574,17 @@ test_that("mashRandNullSample null data capped at available null variants", { ) result <- mashRandNullSample( dat, - nRandom = 2, + nRandom = 100, nNull = 100, excludeCondition = c(), seed = 42 ) + expect_equal(nrow(result$random$z), 3) expect_true(length(result$null) > 0) expect_equal(nrow(result$null$z), 3) }) -test_that("mashRandNullSample extracts null data with bhat/sbhat when enough null variants", { +test_that("mashRandNullSample draws random and null samples from bhat/sbhat", { dat <- list( bhat = data.frame( cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02, 0.01), @@ -2781,6 +2602,7 @@ test_that("mashRandNullSample extracts null data with bhat/sbhat when enough nul excludeCondition = c(), seed = 42 ) + expect_equal(dim(result$random$bhat), c(3L, 2L)) expect_true("null" %in% names(result)) expect_true("bhat" %in% names(result$null)) expect_true("sbhat" %in% names(result$null)) @@ -2788,149 +2610,6 @@ test_that("mashRandNullSample extracts null data with bhat/sbhat when enough nul expect_equal(nrow(result$null$sbhat), 4) }) -test_that("mashRandNullSample excludeCondition with numeric index errors on z path", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3, 0.4, 0.5), - cond2 = c(0.5, 0.4, 0.3, 0.2, 0.1), - cond3 = c(0.3, 0.3, 0.3, 0.3, 0.3) - ) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = 3, - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample excludeCondition with numeric index errors on bhat path", { - dat <- list( - bhat = data.frame( - cond1 = c(0.01, 0.02, 0.01, 0.03, 0.02), - cond2 = c(0.02, 0.01, 0.03, 0.01, 0.02), - cond3 = c(0.01, 0.01, 0.01, 0.01, 0.01) - ), - sbhat = data.frame( - cond1 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond2 = c(0.1, 0.1, 0.1, 0.1, 0.1), - cond3 = c(0.1, 0.1, 0.1, 0.1, 0.1) - ) - ) - expect_error( - mashRandNullSample( - dat, - nRandom = 3, - nNull = 2, - excludeCondition = 3, - seed = 42 - ), - "excludeCondition are not present" - ) -}) - -test_that("mashRandNullSample caps random sample at available rows", { - dat <- list( - z = data.frame( - cond1 = c(0.1, 0.2, 0.3), - cond2 = c(0.2, 0.1, 0.3) - ) - ) - result <- mashRandNullSample( - dat, - nRandom = 100, - nNull = 2, - excludeCondition = c(), - seed = 42 - ) - expect_equal(nrow(result$random$z), 3) -}) - -test_that("filterMixtureComponents filters zero matrices", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - mat2 = matrix(0, 2, 2, dimnames = list(c("A", "B"), c("A", "B"))), - mat3 = matrix( - c(0.8, 0.3, 0.3, 0.9), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 0.5, mat2 = 0.3, mat3 = 0.2) - conditions_to_keep <- c("A", "B") - - result <- filterMixtureComponents(conditions_to_keep, U, w) - - # mat2 should be removed (all zeros) - expect_true(!"mat2" %in% names(result$U)) - # weights should be rescaled to maintain sum - expect_equal(sum(result$w), sum(w), tolerance = 1e-10) -}) - -test_that("filterMixtureComponents removes low weight components", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ), - mat2 = matrix( - c(0.8, 0.3, 0.3, 0.9), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 0.999, mat2 = 0.00001) # mat2 below default cutoff - conditions_to_keep <- c("A", "B") - - result <- filterMixtureComponents(conditions_to_keep, U, w, wCutoff = 1e-04) - expect_true(!"mat2" %in% names(result$U)) -}) - -test_that("filterMixtureComponents errors on missing condition", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.5, 1), - 2, - 2, - dimnames = list(c("A", "B"), c("A", "B")) - ) - ) - w <- c(mat1 = 1.0) - expect_error( - filterMixtureComponents(c("A", "C"), U, w), - "not found in matrix" - ) -}) - -test_that("filterMixtureComponents subsets conditions", { - U <- list( - mat1 = matrix( - c(1, 0.5, 0.2, 0.5, 1, 0.3, 0.2, 0.3, 1), - 3, - 3, - dimnames = list(c("A", "B", "C"), c("A", "B", "C")) - ) - ) - w <- c(mat1 = 1.0) - - result <- filterMixtureComponents(c("A", "B"), U, w) - expect_equal(nrow(result$U[[1]]), 2) - expect_equal(ncol(result$U[[1]]), 2) -}) - test_that(".mashSumStatsToMatrices: auto picks BETA+SE when present", { ss <- .mssm_makeQtlSumStats(function(i, n) { list( @@ -3032,11 +2711,20 @@ test_that(".mashObjectMatrices errors when marginal effects lack the required co method = "susie", entry = list(.sc_makeFineMappingRow(3)) ) - # Force a marginal-effects table with no `context` column (as an mv/f-SuSiE + # Force marginal effects with no `context` column (as an mv/f-SuSiE # result trimmed of marginal sumstats would yield): mash cannot pivot it. testthat::local_mocked_bindings( marginalEffects = function(x, ...) { - data.frame(variant_id = "v", beta = 1, se = 1) + # mcols set apart: `se =` passed to GRanges() would partially + # match its `seqnames` formal. + S4Vectors::`mcols<-`( + GenomicRanges::GRanges("chr1:100"), + value = S4Vectors::DataFrame( + variant_id = "chr1:100:A:G", + beta = 1, + se = 1 + ) + ) }, .package = "pecotmr" ) @@ -3148,7 +2836,7 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), - CHR = "1", + CHR = "chr1", BP = seq(100L, by = 100L, length.out = 5L), A1 = "A", A2 = "G", @@ -3187,7 +2875,7 @@ test_that(".mashSumStatsToMatrices fills missing variants with bhat=0 / sbhat=10 ), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") expect_equal(dim(out$b), c(5L, 2L)) @@ -3208,7 +2896,7 @@ test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", + CHR = "chr1", BP = c(100L, 200L, 300L), A1 = "A", A2 = "G", @@ -3248,7 +2936,7 @@ test_that(".mashSumStatsToMatrices disambiguates rownames across (study, trait) ), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") # 3 variants per block × 2 blocks = 6 rows @@ -3270,7 +2958,7 @@ test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", + CHR = "chr1", BP = c(100L, 200L, 300L), A1 = "A", A2 = "G", @@ -3299,7 +2987,7 @@ test_that(".mashSumStatsToMatrices errors when entry lacks SNP mcol", { entry = list(gr), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) expect_error( pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto"), @@ -3315,7 +3003,7 @@ test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", + CHR = "chr1", BP = c(100L, 200L, 300L), A1 = "A", A2 = "G", @@ -3353,7 +3041,7 @@ test_that(".mashSumStatsToMatrices on GwasSumStats: studies become columns", { ), genome = "hg19", ldReference = gh, - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) out <- pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "auto") expect_equal(ncol(out$b), 2L) @@ -3389,7 +3077,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", + CHR = "chr1", BP = c(100L, 200L, 300L), A1 = "A", A2 = "G", @@ -3418,7 +3106,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has empty QC info", { entry = list(gr), genome = "hg19", ldReference = gh, - qcInfo = list() + qcOptions = list() ) # empty QC info expect_error( pecotmr:::.mashSumStatsToMatrices(ss, "strong"), @@ -3433,7 +3121,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * (1:3)), - CHR = "1", + CHR = "chr1", BP = c(100L, 200L, 300L), A1 = "A", A2 = "G", @@ -3451,7 +3139,7 @@ test_that(".mashSumStatsToMatrices errors when SumStats has zero entries", { genome = "hg19", ldReference = gh, varY = numeric(0), - qcInfo = list(prebuilt = "synthetic") + qcOptions = list(prebuilt = "synthetic") ) expect_error( pecotmr:::.mashSumStatsToMatrices(ss, "strong"), @@ -3507,8 +3195,12 @@ test_that("qtlSumStatsFromZMatrix: decodes chrom/pos from ids, synthesises when e <- sumStats(qss, studyName = "s1", context = "ctx", trait = "mash") expect_equal(GenomicRanges::start(e)[1], 250L) # decoded expect_true(GenomicRanges::start(e)[2] >= 1L) # synthetic fallback - # un-parseable chrom falls back to chr1 (never NA) - expect_false(any(is.na(as.character(GenomicRanges::seqnames(e))))) + # un-parseable chrom falls back to chr1 (never NA), and a decoded one is + # spelled in UCSC style like it + expect_identical( + as.character(GenomicRanges::seqnames(e)), + c("chr1", "chr1") + ) # SNP ids are carried through unchanged expect_equal(S4Vectors::mcols(e)$SNP, rownames(z)) }) @@ -3519,7 +3211,7 @@ test_that("qtlSumStatsFromZMatrix: NULL rownames get synthetic variant ids", { expect_equal(S4Vectors::mcols(qss[[1]])$SNP, c("var1", "var2")) }) -test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set", { +test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcOptions", { z <- matrix(rnorm(6), nrow = 3, dimnames = list(NULL, c("x", "y"))) qss <- qtlSumStatsFromZMatrix( z, @@ -3534,8 +3226,10 @@ test_that("qtlSumStatsFromZMatrix: placeholders and pass-through qcInfo are set" expect_equal(unique(mc$A1), "T") expect_equal(unique(mc$A2), "C") expect_equal(unique(mc$N), 500L) - expect_equal(qcInfo(qss)$role, "strong") - expect_equal(length(qcInfo(qss)$entryAudit), 2L) # one slot per context + expect_equal(qcOptions(qss)$role, "strong") + # No QC has run: the audit names one row per context and records nothing. + expect_equal(nrow(qcInfo(qss)), 2L) + expect_null(mcols(qss)$qcAudit) }) test_that("qtlSumStatsFromZMatrix: columns can map to traits or context x trait pairs", { @@ -3661,7 +3355,7 @@ test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholde expect_equal(mc$SNP, c("var1", "var2")) expect_equal(unique(mc$A1), "T") expect_equal(unique(mc$N), 500L) - expect_equal(qcInfo(qss)$role, "strong") + expect_equal(qcOptions(qss)$role, "strong") }) test_that("mashInput: QtlSumStats path returns the flat b/s/z + XtX contract", { @@ -3731,12 +3425,12 @@ test_that("mashInput: a fine-mapping result with no credible set: no strong", { stringsAsFactors = FALSE ) } - e1 <- fineMappingRow( + e1 <- FineMappingRow( variantIds = vids, susieFit = list(x = 1), topLoci = noCsTL(rnorm(6)) ) - e2 <- fineMappingRow( + e2 <- FineMappingRow( variantIds = vids, susieFit = list(x = 1), topLoci = noCsTL(rnorm(6)) @@ -3890,7 +3584,7 @@ test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { expect_equal(GenomicRanges::start(gr), c(1L, 2L)) }) -test_that("mashWrapper: argument guards fire", { +test_that("mash data filters and merge: argument guards fire", { expect_error( filterInvalidSummaryStat("not-a-list"), "datList.*Must be of type 'list'" @@ -3938,3 +3632,81 @@ test_that(".mashFilterZ leaves a list with no z-carrying partition alone", { datList <- list(other = list(bhat = matrix(1))) expect_identical(pecotmr:::.mashFilterZ(datList, 0.5, NULL), datList) }) + +# =========================================================================== +# A GWAS study split across rows +# =========================================================================== + +test_that("mash reads each study once however many rows it spans", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:6), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:6)), + A1 = "A", + A2 = "G", + Z = c(3, -1, 0.5, 2, -2.5, 1), + N = 1000L + ) + gss <- GwasSumStats( + studyName = c("g1", "g2"), + entry = list(gr, gr), + genome = "hg19", + qcOptions = list(step1 = "ok"), + region = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(1L, 351L), c(350L, 1000L)) + ) + ) + expect_equal(nrow(gss), 4L) + reads <- 0L + original <- pecotmr:::.mashRowDf + local_mocked_bindings( + .mashRowDf = function(...) { + reads <<- reads + 1L + original(...) + }, + .package = "pecotmr" + ) + mats <- pecotmr:::.mashSumStatsToMatrices(gss, "probe", inputScale = "z") + # One read per study, each stitching both of its rows. + expect_identical(reads, 2L) + # And the matrices are the unsplit studies'. + whole <- GwasSumStats( + studyName = c("g1", "g2"), + entry = list(gr, gr), + genome = "hg19", + qcOptions = list(step1 = "ok") + ) + expect_equal( + mats, + pecotmr:::.mashSumStatsToMatrices(whole, "probe", inputScale = "z") + ) +}) + +test_that("a GWAS fine-mapping result's conditions are its studies", { + block <- function(studyName, offset) { + list(study = studyName, entry = .sc_makeFineMappingRow(3, offset)) + } + rows <- list( + block("g1", 0L), + block("g1", 10000L), + block("g2", 0L), + block("g2", 10000L) + ) + fmr <- GwasFineMappingResult( + studyName = map_chr(rows, "study"), + method = rep("susie", 4L), + entry = map(rows, "entry"), + blockId = rep(c("chr1_1_5000", "chr1_5001_20000"), 2L) + ) + mats <- pecotmr:::.mashFmrMatrices(fmr, coverage = 0.95) + expect_identical(colnames(mats$b), c("g1", "g2")) + expect_equal(nrow(mats$b), 6L) + # Set 1 of each block is its own set, so each block contributes a lead. + expect_identical( + rownames(mats$b)[mats$strongRows], + c("chr1:100:A:G", "chr1:10100:A:G") + ) +}) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index cb2e6fc6..b83f0e1d 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -1,83 +1,21 @@ context("mash_wrapper") # =========================================================================== -# filterInvalidSummaryStat +# mashModelFit / mashPosterior and the mashr / udr engine-argument +# constructors (R/mashWrapper.R) # =========================================================================== -# =========================================================================== -# filterMixtureComponents -# =========================================================================== - -# =========================================================================== -# mergeMashData -# =========================================================================== - -# =========================================================================== -# mashRandNullSample -# =========================================================================== - -# mashPipeline integration tests were removed in the S4 refactor: the -# legacy matrix-list input (strong.b/strong.s/random.b/random.s/null.b/null.s) -# is no longer accepted. The new API takes a named list of QtlSumStats / -# GwasSumStats objects, which is non-trivial to mock without exercising the -# full SumStats QC pipeline. Cover mashPipeline behavior end-to-end via the -# pipeline-level integration tests instead. - -# === Tests migrated from test_mrmashWrapper.R (filterMixtureComponents) === - -# =========================================================================== -# Tests from test_misc_round3.R (mrmashWrapper coverage boost) -# =========================================================================== - -# ========================================================================= -# mrmashWrapper.R: computeW0 (lines 284-298) -# ========================================================================= - -# =========================================================================== -# .mashSumStatsToMatrices — inputScale resolution -# =========================================================================== - -# =========================================================================== -# .mashObjectMatrices / .mashObjectPartitions -# =========================================================================== - -# =========================================================================== -# .mashSumStatsToMatrices — matrix assembly behaviour (NA fill, -# rowname disambiguation, multi-context shape) on the bundled fixture -# and on hand-built partial-coverage data. -# =========================================================================== - -# =========================================================================== -# .mashSumStatsToMatrices — GwasSumStats path + input-validation errors -# =========================================================================== - -# =========================================================================== -# mergeMashData — oneData-empty branch (returns resData unchanged) -# =========================================================================== - -# =========================================================================== -# qtlSumStatsFromZMatrix -# =========================================================================== - -# =========================================================================== -# qtlSumStatsFromBetaMatrix (beta-scale sibling of qtlSumStatsFromZMatrix) -# =========================================================================== - -# =========================================================================== -# mashInput (unified strong/random/null assembly from S4 objects) -# =========================================================================== +delayedAssign(".mwModel", .mashTestModel(.mwSs)) test_that("mashModelFit returns a fitted mash model", { skip_if_not_installed("mashr") - ss <- mashFixture() - m <- .mashTestModel(ss) - expect_s3_class(m, "mash") - expect_false(is.null(m$fitted_g)) + expect_s3_class(.mwModel, "mash") + expect_false(is.null(.mwModel$fitted_g)) }) test_that("mashModelFit validates the prior and the fitOn entry", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mwSs expect_error( mashModelFit(list(random = ss), alpha = 0, priorCovariances = list()), "non-empty named list" @@ -94,27 +32,23 @@ test_that("mashModelFit validates the prior and the fitOn entry", { test_that("mashModelFit accepts either prior shape and fits identically", { skip_if_not_installed("mashr") - ss <- mashFixture() + # .mwModel is the fit of this same prior given as a bare list. ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) wrapped <- list(U = ulist, w = NULL, loglik = NULL) - - fit <- function(prior) { - suppressMessages(suppressWarnings(mashModelFit( - list(random = ss), - alpha = 0, - priorCovariances = prior, - vhat = diag(3), - setSeed = 1L - ))) - } - expect_equal(fit(wrapped)$loglik, fit(ulist)$loglik) + fit <- suppressMessages(suppressWarnings(mashModelFit( + list(random = .mwSs), + alpha = 0, + priorCovariances = wrapped, + vhat = diag(3), + setSeed = 1L + ))) + expect_equal(fit$loglik, .mwModel$loglik) }) test_that("mashPosterior returns posterior matrices with covariance", { skip_if_not_installed("mashr") - ss <- mashFixture() post <- suppressMessages(suppressWarnings( - mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)) + mashPosterior(.mwModel, .mwSs, alpha = 0, vhat = diag(3)) )) expect_true(all( c("PosteriorMean", "PosteriorSD", "lfsr", "PosteriorCov") %in% @@ -126,11 +60,10 @@ test_that("mashPosterior returns posterior matrices with covariance", { test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { skip_if_not_installed("mashr") - ss <- mashFixture() post <- suppressMessages(suppressWarnings( mashPosterior( - .mashTestModel(ss), - ss, + .mwModel, + .mwSs, alpha = 0, vhat = diag(3), outputPosteriorCov = FALSE @@ -142,11 +75,11 @@ test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { test_that("mashPosterior(excludeCondition) drops the condition from model + output", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mwSs conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) post <- suppressMessages(suppressWarnings( mashPosterior( - .mashTestModel(ss), + .mwModel, ss, alpha = 0, vhat = diag(3), @@ -159,11 +92,10 @@ test_that("mashPosterior(excludeCondition) drops the condition from model + outp test_that("mashPosterior errors on an unknown excludeCondition", { skip_if_not_installed("mashr") - ss <- mashFixture() expect_error( mashPosterior( - .mashTestModel(ss), - ss, + .mwModel, + .mwSs, alpha = 0, vhat = diag(3), excludeCondition = "not_a_condition" @@ -174,7 +106,7 @@ test_that("mashPosterior errors on an unknown excludeCondition", { test_that("mashModelFit: SimpleList input + default (NULL) vhat", { skip_if_not_installed("mashr") - ss <- mashFixture() + ss <- .mwSs m <- suppressMessages(suppressWarnings( mashModelFit( S4Vectors::SimpleList(random = ss), @@ -188,8 +120,8 @@ test_that("mashModelFit: SimpleList input + default (NULL) vhat", { test_that("mashPosterior: default (NULL) vhat and excludeCondition dropping every condition", { skip_if_not_installed("mashr") - ss <- mashFixture() - model <- .mashTestModel(ss) + ss <- .mwSs + model <- .mwModel conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) # NULL vhat path: omit vhat so mashPosterior fills the identity default. post <- suppressMessages(suppressWarnings(mashPosterior( @@ -315,10 +247,13 @@ test_that("the mash constructors carry their pecotmr defaults", { expect_length(MashOptions(), 0L) }) -test_that("mashDataArgs reaches mashr::mash_set_data", { +test_that("mashDataArgs and mashArgs reach mashr::mash_set_data and mash", { skip_if_not_installed("mashr") - seen <- NULL - real <- mashr::mash_set_data + # One recorded fit serves both bundles: each mash() call is costly. + dataSeen <- NULL + mashSeen <- NULL + realData <- mashr::mash_set_data + realMash <- mashr::mash ss <- mashFixture(20L) suppressMessages(suppressWarnings(with_mocked_bindings( mashModelFit( @@ -327,61 +262,38 @@ test_that("mashDataArgs reaches mashr::mash_set_data", { priorCovariances = mashTinyPrior(), vhat = diag(3), mashDataArgs = MashDataOptions(zero_Shat_reset = 0.5), + mashArgs = MashOptions(nullweight = 7, verbose = FALSE), setSeed = 1L ), mash_set_data = function(...) { - seen <<- list(...) - real(...) + dataSeen <<- list(...) + realData(...) }, - .package = "mashr" - ))) - expect_equal(seen$zero_Shat_reset, 0.5) - # The pecotmr default rides along unless the caller overrides it. - expect_equal(seen$zero_Bhat_Shat_reset, 1000) -}) - -test_that("mashArgs reaches mashr::mash", { - skip_if_not_installed("mashr") - seen <- NULL - real <- mashr::mash - ss <- mashFixture(20L) - suppressMessages(suppressWarnings(with_mocked_bindings( - mashModelFit( - list(random = ss), - alpha = 0, - priorCovariances = mashTinyPrior(), - vhat = diag(3), - mashArgs = MashOptions(nullweight = 7, verbose = FALSE), - setSeed = 1L - ), mash = function(...) { - seen <<- list(...) - real(...) + mashSeen <<- list(...) + realMash(...) }, .package = "mashr" ))) - expect_equal(seen$nullweight, 7) - expect_false(seen$verbose) + expect_equal(dataSeen$zero_Shat_reset, 0.5) + # The pecotmr default rides along unless the caller overrides it. + expect_equal(dataSeen$zero_Bhat_Shat_reset, 1000) + expect_equal(mashSeen$nullweight, 7) + expect_false(mashSeen$verbose) # The entry point keeps owning outputlevel and the data/prior pair. - expect_equal(seen$outputlevel, 4L) + expect_equal(mashSeen$outputlevel, 4L) }) test_that("mashPosterior forwards posteriorArgs", { skip_if_not_installed("mashr") seen <- NULL real <- mashr::mash_compute_posterior_matrices - ss <- mashFixture(20L) - model <- suppressMessages(suppressWarnings(mashModelFit( - list(random = ss), - alpha = 0, - priorCovariances = mashTinyPrior(), - vhat = diag(3), - setSeed = 1L - ))) + # Built before the mock is in place, so only mashPosterior is recorded. + model <- .mwModel suppressMessages(suppressWarnings(with_mocked_bindings( mashPosterior( model, - ss, + .mwSs, alpha = 0, vhat = diag(3), posteriorArgs = MashPosteriorOptions(pi_thresh = 1e-8) @@ -395,29 +307,6 @@ test_that("mashPosterior forwards posteriorArgs", { expect_equal(seen$pi_thresh, 1e-8) }) -test_that("the udr engine runs on the z scale, where udr picks TED", { - skip_if_not_installed("mashr") - skip_if_not_installed("udr") - # The companion to the alpha = 0 run above: both existing udr tests were - # on the beta scale, so the branch that lets udr choose was unexercised. - ss <- mashFixture() - pc <- suppressMessages(suppressWarnings( - mashPriorCovariances( - list(strong = ss), - alpha = 1, - vhat = diag(3), - engine = CovUdrOptions( - init = UdInitOptions(n_unconstrained = 2L), - fit = UdFitOptions(maxiter = 20L) - ), - setSeed = 1L - ) - )) - expect_gt(length(pc$U), 0L) - expect_true(all(map_lgl(pc$U, function(m) all(dim(m) == c(3L, 3L))))) - expect_equal(sum(pc$w), 1, tolerance = 1e-6) -}) - test_that("UdFitOptions checks unconstrained.update's value, not just its name", { skip_if_not_installed("udr") # udr validates the NAME but not the value: compute_penalty() is two diff --git a/tests/testthat/test_overlapTopLoci.R b/tests/testthat/test_overlapTopLoci.R index 73c43694..38132470 100644 --- a/tests/testthat/test_overlapTopLoci.R +++ b/tests/testthat/test_overlapTopLoci.R @@ -25,7 +25,7 @@ context("overlapTopLoci") ) } .ot_entry <- function(tl) { - fineMappingRow( + FineMappingRow( variantIds = tl$variant_id, susieFit = list(fake = TRUE), topLoci = tl @@ -70,6 +70,7 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli ) ov <- overlapTopLoci(qtl, gwas, signalCutoff = 0) + expect_s4_class(ov, "GRanges") # variant key kept once; every other column prefixed qtl_ / gwas_ cols <- names(S4Vectors::mcols(ov)) @@ -82,11 +83,12 @@ test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-fli # per-context QTL rows preserved expect_setequal(unique(ov$qtl_context), c("ctx1", "ctx2")) - # v1 unflipped: gwas beta unchanged (+0.6); v2 swapped: sign-flipped (-0.5) + # v1 unflipped: gwas posterior effect unchanged (+0.6); v2 swapped: + # sign-flipped (-0.5) v1 <- ov[ov$variant_id == "chr1:100:A:G", ] v2 <- ov[ov$variant_id == "chr1:200:A:G", ] - expect_true(all(abs(v1$gwas_beta - 0.60) < 1e-9)) - expect_true(all(abs(v2$gwas_beta + 0.50) < 1e-9)) + expect_equal(v1$gwas_posterior_effect, c(0.60, 0.60)) + expect_equal(v2$gwas_posterior_effect, c(-0.50, -0.50)) # af complemented on the swapped variant (0.7 -> 0.3), untouched otherwise expect_true(all(abs(v2$gwas_af - 0.30) < 1e-9)) expect_true(all(abs(v1$gwas_af - 0.20) < 1e-9)) @@ -160,36 +162,3 @@ test_that("overlapTopLoci returns an empty merge when a side has no signal", { # the empty result is still ranges (.overlapToGRanges empty guard) expect_s4_class(df, "GRanges") }) - -test_that("overlapTopLoci returns a GRanges of the shared variants", { - q <- .ot_entry(.ot_tl( - c("chr1:100:A:G", "chr1:200:A:G"), - A1 = c("G", "G"), - A2 = c("A", "A"), - pm = c(0.3, 0.4), - af = c(0.3, 0.4) - )) - g <- .ot_entry(.ot_tl( - "chr1:100:A:G", - A1 = "G", - A2 = "A", - pm = 0.6, - af = 0.2 - )) - qtl <- QtlFineMappingResult( - studyName = "s", - context = "c", - trait = "t", - method = "susie", - entry = list(q) - ) - gwas <- GwasFineMappingResult( - studyName = "g", - method = "susie", - entry = list(g) - ) - gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0) - expect_s4_class(gr, "GRanges") - expect_equal(length(gr), 1L) - expect_true("gwas_posterior_effect" %in% names(S4Vectors::mcols(gr))) -}) diff --git a/tests/testthat/test_pvalCombineWrappers.R b/tests/testthat/test_pvalCombineWrappers.R index 2e50f16e..4a022ec1 100644 --- a/tests/testthat/test_pvalCombineWrappers.R +++ b/tests/testthat/test_pvalCombineWrappers.R @@ -13,16 +13,6 @@ test_that("waldTestPval: returns two-sided p-values matching stats::pt", { expect_equal(res, expected) }) -test_that("waldTestPval: returns 1 when beta is zero", { - expect_equal(waldTestPval(0, 0.1, 50), 1, tolerance = 1e-12) -}) - -test_that("waldTestPval: is vectorised over beta/se", { - res <- waldTestPval(c(1, 2, 3), c(0.5, 0.5, 0.5), 100) - expect_length(res, 3) - expect_true(all(res > 0 & res <= 1)) -}) - # =========================================================================== # pvalAcat (internal) # =========================================================================== @@ -51,6 +41,7 @@ test_that("pvalAcat: clips very-near-1 p-values to 0.99", { test_that("pvalAcat: small p-values produce small combined p", { combined <- pecotmr:::pvalAcat(rep(1e-6, 5)) + expect_gt(combined, 0) expect_lt(combined, 1e-5) }) @@ -312,7 +303,7 @@ test_that("combinePValues dispatches aSPU and GATES", { }) # =========================================================================== -# Tests migrated from test_misc.R (p-value combiners + waldTestPval) +# pvalHmp # =========================================================================== test_that("pvalHmp returns valid p-value", { @@ -321,26 +312,13 @@ test_that("pvalHmp returns valid p-value", { result <- pecotmr:::pvalHmp(pvals) expect_true(is.numeric(result)) expect_true(result >= 0 && result <= 1) - # The harmonic mean is L/sum(1/p) where L = length(unique(pvals)) - L <- length(unique(pvals)) - HMP <- L / sum(1 / pvals) - # Result should be based on pLandau(1/HMP, ...) and be smaller than the arithmetic mean + # pLandau's tail at 1 / HMP, HMP = L / sum(1 / p): for these inputs it + # sits below both their arithmetic mean and the largest of them. expect_true(result < mean(pvals)) - # Verify the result is less than the smallest individual p-value is not required, - # but it should be in a reasonable range relative to the harmonic mean expect_true(result < 0.1) }) -test_that("pvalHmp uses unique p-values only", { - skip_if_not_installed("harmonicmeanp") - pvals <- c(0.01, 0.01, 0.05, 0.05, 0.3) - result <- pecotmr:::pvalHmp(pvals) - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - test_that("pvalHmp errors when package not available", { skip_if( requireNamespace("harmonicmeanp", quietly = TRUE), @@ -353,26 +331,6 @@ test_that("pvalHmp errors when package not available", { # pvalAcat # ============================================================================= -test_that("pvalAcat returns single p-value unchanged", { - expect_equal(pecotmr:::pvalAcat(0.05), 0.05) -}) - - -test_that("pvalAcat combines multiple p-values", { - pvals <- c(0.001, 0.01, 0.1) - combined <- pecotmr:::pvalAcat(pvals) - expect_true(combined > 0 && combined < 1) -}) - - -test_that("pvalAcat with very small p-values does not return NA", { - result <- pecotmr:::pvalAcat(c(1e-10, 1e-8, 1e-6)) - expect_true(is.numeric(result)) - expect_true(!is.na(result)) - expect_true(result > 0 && result <= 1) -}) - - test_that("pvalAcat with all large p-values returns large combined p-value", { result <- pecotmr:::pvalAcat(c(0.8, 0.9, 0.95)) expect_true(is.numeric(result)) @@ -380,48 +338,10 @@ test_that("pvalAcat with all large p-values returns large combined p-value", { }) -test_that("pvalAcat uses asymptotic approximation for p < 1e-15", { - # p-values below 1e-15 use 1/(p*pi) instead of tan() - result <- pecotmr:::pvalAcat(c(1e-20, 1e-18, 0.01)) - expect_true(is.numeric(result)) - expect_true(result > 0 && result < 1) - expect_false(is.na(result)) -}) - # ============================================================================= # pvalPoolr # ============================================================================= -test_that("pvalPoolr fisher method returns valid p-value", { - skip_if_not_installed("poolr") - pvals <- c(0.01, 0.05, 0.1) - R <- diag(3) - result <- pecotmr:::pvalPoolr(pvals, method = "fisher", R = R) - expect_true(is.numeric(result)) - expect_true(result > 0 && result < 1) -}) - - -test_that("pvalPoolr stouffer method returns valid p-value", { - skip_if_not_installed("poolr") - pvals <- c(0.01, 0.05, 0.1) - R <- diag(3) - result <- pecotmr:::pvalPoolr(pvals, method = "stouffer", R = R) - expect_true(is.numeric(result)) - expect_true(result > 0 && result < 1) -}) - - -test_that("pvalPoolr invchisq method returns valid p-value", { - skip_if_not_installed("poolr") - pvals <- c(0.01, 0.05, 0.1) - R <- diag(3) - result <- pecotmr:::pvalPoolr(pvals, method = "invchisq", R = R) - expect_true(is.numeric(result)) - expect_true(result > 0 && result < 1) -}) - - 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, @@ -435,6 +355,32 @@ test_that("generalized poolr tests reduce to the plain ones when independent", { expect_equal(pecotmr:::pvalPoolr(p, "invchisq", R), poolr::invchisq(p)$p) }) +test_that("pvalPoolr runs poolr's empirical adjustment for every test", { + # poolr names the running test from its own call; with the function + # object inlined into the call it could not, and every empirical + # adjustment failed inside poolr. + skip_if_not_installed("poolr") + p <- c(0.01, 0.2, 0.5) + R <- diag(3) + R[1, 2] <- R[2, 1] <- 0.3 + direct <- list( + fisher = function() poolr::fisher(p, adjust = "empirical", R = R), + stouffer = function() poolr::stouffer(p, adjust = "empirical", R = R), + invchisq = function() poolr::invchisq(p, adjust = "empirical", R = R) + ) + for (method in names(direct)) { + set.seed(1) + got <- pecotmr:::pvalPoolr( + p, + method, + R, + PoolrOptions(adjust = "empirical") + ) + set.seed(1) + expect_equal(got, direct[[method]]()$p, info = method) + } +}) + test_that(".poolrDependence converts R for the adjustment poolr runs", { skip_if_not_installed("poolr") R <- 0.6^abs(outer(1:4, 1:4, "-")) @@ -481,66 +427,6 @@ test_that("pvalPoolr errors on unknown method", { # pvalGbj # ============================================================================= -test_that("pvalGbj gbj method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "gbj") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalGbj hc method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "hc") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalGbj minp method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "minp") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalGbj bj method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "bj") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalGbj ghc method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "ghc") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalGbj gbj_omni method returns valid p-value", { - skip_if_not_installed("GBJ") - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalGbj(z, R, method = "gbj_omni") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - test_that("pvalGbj errors on unknown method", { skip_if_not_installed("GBJ") expect_error( @@ -553,27 +439,6 @@ test_that("pvalGbj errors on unknown method", { # pvalAspu # ============================================================================= -test_that("pvalAspu aspu method returns valid p-value", { - skip_if_not_installed("aSPU") - set.seed(42) - z <- c(2.5, 1.8, 3.0) - R <- diag(3) - result <- pecotmr:::pvalAspu(zScores = z, R = R, method = "aspu") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - -test_that("pvalAspu gates method returns valid p-value", { - skip_if_not_installed("aSPU") - pvals <- c(0.01, 0.05, 0.1) - R <- diag(3) - result <- pecotmr:::pvalAspu(pvals = pvals, R = R, method = "gates") - expect_true(is.numeric(result)) - expect_true(result >= 0 && result <= 1) -}) - - test_that("pvalAspu errors on unknown method", { skip_if_not_installed("aSPU") expect_error( @@ -582,49 +447,9 @@ test_that("pvalAspu errors on unknown method", { ) }) -# ============================================================================= -# ============================================================================= -# findValidFilePath and findValidFilePaths -# ============================================================================= - -test_that("waldTestPval computes correct p-values", { - pval <- waldTestPval(beta = 5, se = 1, n = 100) - expect_true(pval < 0.001) - - pval_zero <- waldTestPval(beta = 0, se = 1, n = 100) - expect_equal(pval_zero, 1.0, tolerance = 1e-10) -}) - - -test_that("waldTestPval handles vector inputs", { - betas <- c(0, 1, 2, 5) - ses <- c(1, 1, 1, 1) - pvals <- waldTestPval(betas, ses, n = 100) - expect_length(pvals, 4) - expect_true(pvals[1] > pvals[4]) -}) - - -test_that("waldTestPval is symmetric in beta sign", { - pval_pos <- waldTestPval(beta = 3, se = 1, n = 50) - pval_neg <- waldTestPval(beta = -3, se = 1, n = 50) - expect_equal(pval_pos, pval_neg, tolerance = 1e-10) -}) - - -test_that("waldTestPval with very large beta gives p near 0", { - pval <- waldTestPval(beta = 100, se = 1, n = 1000) - expect_true(pval < 1e-10) -}) - - -test_that("waldTestPval with very large se gives p near 1", { - pval <- waldTestPval(beta = 1, se = 1000, n = 100) - expect_true(pval > 0.99) -}) # ============================================================================= -# parseRegion +# Argument guards # ============================================================================= test_that("pvalCombine: argument guards fire", { @@ -757,7 +582,10 @@ test_that("combinePValues forwards each method's options to its engine", { ), stouffer = function(...) { seen <<- list(...) - real(...) + # Called by its own name: poolr's empirical adjustment reads + # which test it is from its call. + stouffer <- real + stouffer(...) }, .package = "poolr" ) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index 24eabd86..4cbebd1f 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -1,85 +1,15 @@ context("qtlAssociationPostprocess") -# A deterministic per-gene QtlSumStats: one row per gene carrying the regional -# summary as row columns (p_beta / beta shapes / n_variants), each entry a -# per-variant GRanges (P / af / tss_distance / tes_distance). Deterministic so -# qvalue::qvalue sees a stable p-value distribution. -# drop row columns to omit (e.g. "n_variants", "p_beta", beta shapes), -# for the required-column / missing-input error paths. -# withQvalue attach a per-variant `qvalue` mcol (needed by the qvalue SNP -# significance query), with v1 tracking the gene signal. -# emptyIdx gene indices whose entry is an empty GRanges (no p-values), for -# the "skip genes with no variants" branch. -# naShapeIdx gene indices given an NA beta_shape1 (so qbeta -> NA nominal -# threshold), for the "skip genes with an NA threshold" branch. -# Column counts and the p_beta distribution are unchanged from the base -# fixture, so qvalue::qvalue still estimates pi0 on its default path. -.qapFixture <- function( - nVar = 50L, - nVarFilt = 30L, - drop = character(), - withQvalue = FALSE, - emptyIdx = integer(0), - naShapeIdx = integer(0) -) { - # 6 strong signal p_beta + a deterministic uniform null (ppoints) so - # qvalue::qvalue estimates pi0 on its default path (no fallback needed). - pBeta <- c(10^(-c(8, 7, 6, 5, 4, 3)), stats::ppoints(54)) - G <- length(pBeta) - entries <- map(seq_len(G), function(i) { - if (i %in% emptyIdx) { - return(GenomicRanges::GRanges()) - } # no variants - k <- 4L - pv <- c(pBeta[i] / 5, 0.2, 0.5, 0.8) # min tracks the gene signal - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges( - start = seq(1000L, by = 50L, length.out = k), - width = 1L - ) - ) - mc <- S4Vectors::DataFrame( - SNP = paste0("g", i, "_v", seq_len(k)), - A1 = "A", - A2 = "G", - P = pv, - af = c(0.30, 0.20, 0.005, 0.40), # v3 fails MAF 0.01 - tss_distance = c(0L, 500L, 900000L, 2000000L), # v4 outside 1Mb cis - tes_distance = c(0L, 500L, 900000L, 2000000L) - ) - if (withQvalue) { - mc$qvalue <- c(pBeta[i] / 5, 0.30, 0.60, 0.90) - } - S4Vectors::mcols(gr) <- mc - gr - }) - shape1 <- rep(1, G) - shape1[naShapeIdx] <- NA_real_ - extra <- list( - n_variants = rep(nVar, G), - n_variants_filtered = rep(nVarFilt, G), - p_beta = pBeta, - beta_shape1 = shape1, - beta_shape2 = rep(200, G) - ) - args <- list( - study = rep("s", G), - context = rep("brain", G), - trait = paste0("g", seq_len(G)), - entry = entries, - genome = "hg19", - extraCols = extra[setdiff(names(extra), drop)] - ) - exec(QtlSumStats, !!!args[setdiff(names(args), drop)]) +# The shared fixture without the named row columns, for the required-column / +# missing-input error paths: dropping a column is a cheap mcols edit, where a +# rebuild costs as much as the test itself. +.qapWithout <- function(cols) { + x <- .qapDefaultFixture + kept <- setdiff(colnames(S4Vectors::mcols(x)), cols) + S4Vectors::mcols(x) <- S4Vectors::mcols(x)[, kept, drop = FALSE] + x } -# The default fixture is 60 genes of GRanges + mcols and costs ~0.5s to build, -# which is most of this file's runtime when every test rebuilds it. S4 objects -# are copy-on-modify, so one shared instance is safe; tests needing a variant -# still call .qapFixture() with arguments. -.qapDefaultFixture <- .qapFixture() - test_that("qtlAssociationPostprocess enriches with package-computed columns", { x <- .qapDefaultFixture r <- qtlAssociationPostprocess( @@ -90,7 +20,7 @@ test_that("qtlAssociationPostprocess enriches with package-computed columns", { ) expect_s4_class(r, "QtlSumStats") - expect_false(is.null(qcInfo(r)$associationPostprocess)) # recipe stashed + expect_false(is.null(qcOptions(r)$associationPostprocess)) # recipe stashed # Bonferroni original == min over variants of p.adjust(P, "bonferroni", n). expP <- map_dbl( @@ -178,28 +108,6 @@ test_that("significantQtls (bonferroni) matches the derived threshold rule", { expect_equal(length(sig), expN) }) -test_that("sumStats(annotateSignificance=) adds a derived logical mcol", { - x <- .qapDefaultFixture - r <- qtlAssociationPostprocess(x, methods = "permutation") - gr <- sumStats( - r, - studyName = "s", - context = "brain", - trait = "g1", - annotateSignificance = "permutation" - ) - expect_true("significant" %in% names(S4Vectors::mcols(gr))) - expect_type(S4Vectors::mcols(gr)$significant, "logical") - # matches the permutation rule P < p_nominal_threshold[gene 1] - thr1 <- as.numeric(r$p_nominal_threshold)[1] - exp1 <- if (is.na(thr1)) { - rep(FALSE, length(gr)) - } else { - S4Vectors::mcols(gr)$P < thr1 - } - expect_equal(S4Vectors::mcols(gr)$significant, exp1) -}) - test_that("significance accessors require a postprocessed object", { x <- .qapDefaultFixture # not postprocessed expect_error( @@ -214,34 +122,29 @@ test_that("significance accessors require a postprocessed object", { # qvalue-native error on the primary (no-lambda) call and succeed on the retry # (lambda supplied), then assert the retry value flows through unchanged. -test_that(".qapSafeQvalue retries with lambda=0 on qvalue 'missing or infinite'", { +test_that(".qapSafeQvalue retries both qvalue-native degenerate cases", { skip_if_not_installed("qvalue") - testthat::local_mocked_bindings( - qvalue = function(p, lambda, ...) { - if (missing(lambda)) { - stop("missing or infinite values in the smoother") - } - list(qvalues = rep(0.111, length(p))) - }, - .package = "qvalue" - ) - r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") - expect_true(all(as.numeric(r$q_beta) == 0.111)) -}) - -test_that(".qapSafeQvalue retries with bootstrap pi0 on qvalue 'pi0 <= 0'", { - skip_if_not_installed("qvalue") - testthat::local_mocked_bindings( - qvalue = function(p, lambda, ...) { - if (missing(lambda)) { - stop("ERROR: The estimated pi0 <= 0.") - } - list(qvalues = rep(0.222, length(p))) - }, - .package = "qvalue" - ) - r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") - expect_true(all(as.numeric(r$q_beta) == 0.222)) + # 'missing or infinite' retries with lambda = 0, 'pi0 <= 0' with a + # bootstrap pi0. + for (err in c( + "missing or infinite values in the smoother", + "ERROR: The estimated pi0 <= 0." + )) { + testthat::local_mocked_bindings( + qvalue = function(p, lambda, ...) { + if (missing(lambda)) { + stop(err) + } + list(qvalues = rep(0.111, length(p))) + }, + .package = "qvalue" + ) + r <- qtlAssociationPostprocess( + .qapDefaultFixture, + methods = "permutation" + ) + expect_true(all(as.numeric(r$q_beta) == 0.111), info = err) + } }) test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q)", { @@ -296,8 +199,10 @@ test_that("significantQtls (permutation) uses each gene's nominal threshold", { test_that("significantQtls (permutation) skips genes with an NA threshold", { # Gene 1's NA beta_shape1 makes its qbeta nominal threshold NA, so the mask # loop must `next` past it while still processing the non-NA genes. + x <- .qapDefaultFixture + S4Vectors::mcols(x)$beta_shape1[1L] <- NA_real_ r <- qtlAssociationPostprocess( - .qapFixture(naShapeIdx = 1L), + x, fdrThreshold = 0.1, methods = "permutation" ) @@ -322,31 +227,13 @@ test_that("significantQtls (permutation) skips genes with an NA threshold", { test_that("significantQtls (permutation) errors without a nominal threshold", { # No beta shapes -> postprocess produces no p_nominal_threshold column. r <- qtlAssociationPostprocess( - .qapFixture(drop = c("beta_shape1", "beta_shape2")), + .qapWithout(c("beta_shape1", "beta_shape2")), methods = "permutation" ) expect_null(r$p_nominal_threshold) expect_error(significantQtls(r, "permutation"), "p_nominal_threshold") }) -test_that("significantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { - r <- qtlAssociationPostprocess( - .qapDefaultFixture, - mafCutoff = 0.01, - cisWindow = 1e6 - ) - sig <- significantQtls(r, "bonferroni_filtered", threshold = 0.5) - expect_s4_class(sig, "GRanges") - expect_gt(length(sig), 0) - # Every returned variant must satisfy the filtered keep rule (MAF & cis window). - af <- S4Vectors::mcols(sig)$af - expect_true(all(pmin(af, 1 - af) > 0.01)) - expect_true(all( - S4Vectors::mcols(sig)$tss_distance >= -1e6 & - S4Vectors::mcols(sig)$tes_distance <= 1e6 - )) -}) - test_that("significantQtls (bonferroni) errors when its columns are absent", { r <- qtlAssociationPostprocess(.qapDefaultFixture, methods = "permutation") # no bonferroni expect_error(significantQtls(r, "bonferroni_original"), "columns absent") @@ -355,7 +242,7 @@ test_that("significantQtls (bonferroni) errors when its columns are absent", { test_that("significantQtls (qvalue) selects variants by their qvalue mcol", { skip_if_not_installed("qvalue") r <- qtlAssociationPostprocess( - .qapFixture(withQvalue = TRUE), + .qapDefaultFixture, fdrThreshold = 0.1, methods = "permutation" ) @@ -379,7 +266,7 @@ test_that("significantQtls (qvalue) errors when no event q column exists", { # Drop p_beta so permutation adds no q_beta, and skip bonferroni so there is # no q_bonferroni_min_original either -- yet the object is still postprocessed. r <- qtlAssociationPostprocess( - .qapFixture(drop = "p_beta"), + .qapWithout("p_beta"), methods = "permutation" ) expect_null(r$q_beta) @@ -403,7 +290,7 @@ test_that("significantQtls returns an empty GRanges when nothing is significant" test_that("qtlAssociationPostprocess requires n_variants for Bonferroni", { expect_error( qtlAssociationPostprocess( - .qapFixture(drop = "n_variants"), + .qapWithout("n_variants"), methods = "bonferroni" ), "required for the Bonferroni" @@ -413,7 +300,7 @@ test_that("qtlAssociationPostprocess requires n_variants for Bonferroni", { test_that("qtlAssociationPostprocess requires n_variants_filtered when filtering", { expect_error( qtlAssociationPostprocess( - .qapFixture(drop = "n_variants_filtered"), + .qapWithout("n_variants_filtered"), methods = "bonferroni", mafCutoff = 0.01 ), @@ -475,7 +362,16 @@ test_that("significantQtls(bonferroni_filtered) applies the derived rule on the sum(pmin(1, p * 30) <= varThr) } )) + expect_gt(expN, 0) expect_equal(length(sig), expN) + # Every returned variant satisfies the filtered keep rule (MAF and the + # cis window). + af <- S4Vectors::mcols(sig)$af + expect_true(all(pmin(af, 1 - af) > 0.01)) + expect_true(all( + S4Vectors::mcols(sig)$tss_distance >= -1e6 & + S4Vectors::mcols(sig)$tes_distance <= 1e6 + )) }) test_that(".qapSignificanceMask returns empty masks for an unknown method", { @@ -498,7 +394,7 @@ test_that(".qapSignificanceMask returns empty masks for an unknown method", { genome = "hg19" ) local_mocked_bindings( - qcInfo = function(x) { + qcOptions = function(x) { list( associationPostprocess = list( fdrThreshold = 0.05, diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 9c3b251e..28dd8846 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -30,7 +30,7 @@ context("qtlEnrichmentPipeline") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -60,7 +60,7 @@ context("qtlEnrichmentPipeline") stringsAsFactors = FALSE ) fit <- list(alpha = alpha, pip = setNames(pip, variant_ids), V = 0.1) - fineMappingRow(variantIds = variant_ids, susieFit = fit, topLoci = tl) + FineMappingRow(variantIds = variant_ids, susieFit = fit, topLoci = tl) } .qep_makeGwasFmr <- function( @@ -161,7 +161,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { gfmr <- GwasFineMappingResult( studyName = "G1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = ids, susieFit = list( alpha = matrix(1 / 50, nrow = 1L, ncol = 50L), @@ -177,7 +177,7 @@ test_that("qtlEnrichmentPipeline: the real estimator fills the value columns", { context = "c1", trait = "t1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = ids, susieFit = list( alpha = alpha, @@ -305,7 +305,7 @@ test_that("qtlEnrichmentPipeline: NULL ldReference on the GWAS side errors", { gwasFineMappingResult = gfmr, qtlFineMappingResult = qfmr ), - "must have a non-NULL ldReference" + "row must have an ldReference" ) }) @@ -409,7 +409,7 @@ test_that("qtlEnrichmentPipeline: qtlEnrichment failure produces a warning + ski test_that("qtlEnrichmentPipeline: empty input collections yield the empty schema", { # Build a GwasFineMappingResult whose entries have empty fits so the PIP # vector is empty. - emptyEntry <- fineMappingRow( + emptyEntry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), # no pip -> .enrBuildGwasPipVector returns numeric(0) topLoci = data.frame( @@ -440,8 +440,10 @@ test_that("qtlEnrichmentPipeline: empty input collections yield the empty schema "gwasStudy", "gwasContext", "gwasTrait", + "gwasMethod", "qtlStudy", "qtlContext", + "qtlMethod", names(pecotmr:::.enrNaEnrichment()) ) ) @@ -544,9 +546,7 @@ test_that(".enrBuildQtlRegionsList: returns empty list when the (study, context) # qtlEnrichment() — kernel wrapper + real C++ integration # 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 -# skip_on_covr()). +# (R/qtlEnrichmentPipeline.R::qtlEnrichment) is exercised here directly. # =========================================================================== # Build a small (gwasPip, susieQtlRegions) fixture with a sparse causal @@ -595,7 +595,7 @@ test_that("qtlEnrichment: real C++ kernel returns the expected keys (numGwas + p piQtl = 0.5, lambda = 1, impN = 5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ) expect_type(res, "list") @@ -627,7 +627,7 @@ test_that("qtlEnrichment: a single MI round is estimable, not NaN", { numGwas = 5000, piQtl = 0.5, impN = 1, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE, seed = 1L ) @@ -648,7 +648,7 @@ test_that("qtlEnrichment: numGwas omitted -> estimates piGwas from data + warns" susieQtlRegions = fx$susieQtlRegions, piQtl = 0.5, impN = 5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "numGwas is not provided" @@ -664,7 +664,7 @@ test_that("qtlEnrichment: piQtl omitted -> estimates from susieQtlRegions + warn susieQtlRegions = fx$susieQtlRegions, numGwas = 3000, impN = 5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "piQtl is not provided" @@ -681,7 +681,7 @@ test_that("qtlEnrichment: errors when piGwas resolves to zero", { gwasPip = zeroGwas, susieQtlRegions = fx$susieQtlRegions, piQtl = 0.5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "No association signal found" @@ -696,7 +696,7 @@ test_that("qtlEnrichment: errors when piQtl resolves to zero", { susieQtlRegions = fx$susieQtlRegions, numGwas = 5000, piQtl = 0, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "No QTL associated" @@ -712,7 +712,7 @@ test_that("qtlEnrichment: errors when gwasPip has no names", { susieQtlRegions = fx$susieQtlRegions, numGwas = 5000, piQtl = 0.5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "Variant names are missing in gwasPip" @@ -728,14 +728,14 @@ test_that("qtlEnrichment: errors when susieQtlRegions$pip lacks names", { susieQtlRegions = fx$susieQtlRegions, numGwas = 5000, piQtl = 0.5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE ), "Variant names are missing in susieQtlRegions" ) }) -test_that("qtlEnrichment: tracks unmatched QTL variants in the output", { +test_that("qtlEnrichment: tracks unmatched QTL variants, either alignNames", { fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) # Inject a couple of variant IDs into the QTL fit that don't exist # in the GWAS PIP vector. @@ -743,33 +743,45 @@ test_that("qtlEnrichment: tracks unmatched QTL variants in the output", { newNames[1:2] <- c("1:9999:A:G", "1:9998:A:G") names(fx$susieQtlRegions$fit1$pip) <- newNames colnames(fx$susieQtlRegions$fit1$alpha) <- newNames - res <- qtlEnrichment( - gwasPip = fx$gwasPip, - susieQtlRegions = fx$susieQtlRegions, - numGwas = 3000, - piQtl = 0.5, - impN = 5, - numThreads = 1, - verbose = FALSE - ) - expect_true("unused_xqtl_variants" %in% names(res)) + # alignNames = FALSE is the cheap set-membership branch + # qtlEnrichmentPipeline uses once it has aligned the QTL names against + # the union GWAS panel; both branches report the two injected ids. + for (alignNames in c(TRUE, FALSE)) { + res <- qtlEnrichment( + gwasPip = fx$gwasPip, + susieQtlRegions = fx$susieQtlRegions, + numGwas = 3000, + piQtl = 0.5, + impN = 5, + BPPARAM = BiocParallel::SerialParam(), + verbose = FALSE, + alignNames = alignNames + ) + expect_true( + all( + c("1:9999:A:G", "1:9998:A:G") %in% + unlist(res$unused_xqtl_variants) + ), + info = str_c("alignNames = ", alignNames) + ) + } }) # =========================================================================== -# qtlEnrichment(): verbose messages + alignNames = FALSE branch +# qtlEnrichment(): verbose messages # =========================================================================== test_that("qtlEnrichment: verbose=TRUE emits 'Estimated piGwas'/'Estimated piQtl' messages", { # numGwas = NULL and piQtl = NULL both trigger data-estimation paths; - # with verbose = TRUE each emits a message (lines 391 and 407). + # with verbose = TRUE each emits a message. fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) msgs <- testthat::capture_messages( suppressWarnings(qtlEnrichment( gwasPip = fx$gwasPip, susieQtlRegions = fx$susieQtlRegions, impN = 5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = TRUE )) ) @@ -778,34 +790,6 @@ test_that("qtlEnrichment: verbose=TRUE emits 'Estimated piGwas'/'Estimated piQtl expect_match(allMsgs, "Estimated piQtl") }) -test_that("qtlEnrichment: alignNames=FALSE recomputes only the unmatched set", { - # Exercises the cheap set-membership branch (lines 438-444) used by - # qtlEnrichmentPipeline after it has already aligned QTL names against - # the union GWAS panel. Two injected names are absent from gwasPip, so - # the unmatched-variant accumulation (lines 441-442) runs. - fx <- .qep_makeRealKernelInputs(nSnps = 30, causalIdx = c(5, 15)) - newNames <- names(fx$susieQtlRegions$fit1$pip) - newNames[1:2] <- c("1:9999:A:G", "1:9998:A:G") - names(fx$susieQtlRegions$fit1$pip) <- newNames - colnames(fx$susieQtlRegions$fit1$alpha) <- newNames - res <- qtlEnrichment( - gwasPip = fx$gwasPip, - susieQtlRegions = fx$susieQtlRegions, - numGwas = 3000, - piQtl = 0.5, - impN = 5, - numThreads = 1, - verbose = FALSE, - alignNames = FALSE - ) - expect_true("unused_xqtl_variants" %in% names(res)) - expect_true(any( - c("1:9999:A:G", "1:9998:A:G") %in% - unlist(res$unused_xqtl_variants) - )) -}) - - # =========================================================================== # .enrFlattenEnrichment(): shape coercion + NA fallbacks # =========================================================================== @@ -861,7 +845,7 @@ test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with # Unnamed pip of length 2 against 3 variant ids -> ids come from # variantIds and length(ids) != length(pip) -> the block is skipped, # leaving no pieces -> numeric(0). - badEntry <- fineMappingRow( + badEntry <- FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), susieFit = list(pip = c(0.1, 0.2)), topLoci = data.frame( @@ -888,7 +872,7 @@ test_that(".enrBuildGwasPipVector: skips a block whose pip length disagrees with # =========================================================================== test_that(".enrBuildQtlRegionsList: skips an entry whose fit lacks alpha/pip", { - badEntry <- fineMappingRow( + badEntry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame( @@ -914,44 +898,13 @@ test_that(".enrBuildQtlRegionsList: skips an entry whose fit lacks alpha/pip", { ) }) -test_that(".enrBuildQtlRegionsList: skips a fit with no V and no prior_variance", { - noVfit <- list( - alpha = matrix(c(0.6, 0.4), nrow = 1), - pip = setNames(c(0.6, 0.4), c("chr1:100:A:G", "chr1:200:A:G")) - ) - entry <- fineMappingRow( - variantIds = c("chr1:100:A:G", "chr1:200:A:G"), - susieFit = noVfit, - topLoci = data.frame( - variant_id = c("chr1:100:A:G", "chr1:200:A:G"), - pip = c(0.6, 0.4), - stringsAsFactors = FALSE - ) - ) - qfmr <- QtlFineMappingResult( - studyName = "Q1", - context = "c1", - trait = "t1", - method = "susie", - entry = list(entry), - ldReference = NULL - ) - expect_equal( - length(pecotmr:::.enrBuildQtlRegionsList( - qfmr, - .qep_qtlIdent("Q1", "c1") - )), - 0L - ) -}) - test_that(".enrBuildQtlRegionsList: names an unnamed pip from the entry's variant ids", { unnamedPipFit <- list( alpha = matrix(c(0.6, 0.4), nrow = 1), pip = c(0.6, 0.4), # unnamed -> names assigned from variantIds V = 0.1 ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), susieFit = unnamedPipFit, topLoci = data.frame( @@ -1002,7 +955,7 @@ test_that("qtlEnrichmentPipeline: empty QTL collection errors with the no-triple test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies", { # Two GWAS studies -> each QTL tuple's alignment is computed for the # first study (cache miss) and served from cache for the second - # (alignTuple early-return branch, line 119). + # (alignTuple early-return branch). e1 <- .qep_makeFmEntry( variant_ids = sprintf("chr1:%d:A:G", 100L * (1:3)), pip = c(0.5, 0.2, 0.1) @@ -1032,7 +985,7 @@ test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies test_that("qtlEnrichmentPipeline: a tuple with no usable QTL regions warns and is skipped", { gfmr <- .qep_makeGwasFmr() - emptyQtlEntry <- fineMappingRow( + emptyQtlEntry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame( @@ -1072,7 +1025,7 @@ test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { k = 1L, alignedByTuple = list(cnd), qtlEnrichmentParam = QtlEnrichmentParam(), - numThreads = 1L, + BPPARAM = BiocParallel::SerialParam(), seed = NULL, verbose = FALSE, gwasFineMappingResult = NULL, @@ -1159,3 +1112,111 @@ test_that("qtlEnrichmentPipeline refuses a bare list for qtlEnrichmentParam", { "must be built with QtlEnrichmentParam" ) }) + +test_that("qtlEnrichmentPipeline refuses overlapping rows on two references", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:9)) + ldm <- function(rho) { + LdMatrix(`dimnames<-`(rho^abs(outer(1:9, 1:9, "-")), list(ids, ids))) + } + gfmr <- pecotmr:::.withRowLdRefs(.qep_makeGwasFmr(), ldm(0.2)) + qfmr <- pecotmr:::.withRowLdRefs(.qep_makeQtlFmr(), ldm(0.8)) + expect_error( + pecotmr:::.enrValidateInputs(gfmr, qfmr), + "disagree on the LD" + ) +}) + +test_that("qtlEnrichmentPipeline keeps each fine-mapping method's fits apart", { + # The same GWAS blocks fine-mapped by two methods are two outcome PIP + # vectors, and the same QTL regions by two methods two annotations. + gwas <- .qep_makeGwasFmr(n_blocks = 2L) + gwas2 <- gwas + S4Vectors::mcols(gwas2)$method <- "ser" + gfmr <- combineFineMappingResults(gwas, gwas2) + qtl <- .qep_makeQtlFmr() + qtl2 <- qtl + S4Vectors::mcols(qtl2)$method <- "ser" + qfmr <- combineFineMappingResults(qtl, qtl2) + seen <- new.env() + seen$regions <- integer(0) + local_mocked_bindings( + qtlEnrichment = function(gwasPip, susieQtlRegions, ...) { + seen$regions <- c(seen$regions, length(susieQtlRegions)) + .qep_mockEnrichment(2.0)(gwasPip, susieQtlRegions, ...) + }, + .package = "pecotmr" + ) + out <- qtlEnrichmentPipeline( + gwasFineMappingResult = gfmr, + qtlFineMappingResult = qfmr, + verbose = FALSE + ) + expect_equal(nrow(out), 4L) + expect_setequal( + str_c(out$gwasMethod, out$qtlMethod, sep = "/"), + c("susie/susie", "susie/ser", "ser/susie", "ser/ser") + ) + # Each annotation is one method's one region, counted once. + expect_true(all(seen$regions == 1L)) + # The GWAS outcome is both blocks of its fit. + ident <- list( + study = "G1", + context = NA_character_, + trait = NA_character_, + method = "ser" + ) + expect_length(pecotmr:::.enrBuildGwasPipVector(gfmr, ident), 6L) +}) + +# =========================================================================== +# A narrowed row's PIPs are named by the variants of its fit +# =========================================================================== + +test_that("enrichment names a narrowed row's PIPs by its fit's variants", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + pip <- c(0.5, 0.3, 0.2) + fit <- list(pip = pip, alpha = matrix(pip, 1L), V = 1) + tl <- data.frame(variant_id = vids, pip = pip) + row <- FineMappingRow(vids, fit, tl) + gwas <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(row) + ) + expect_equal( + pecotmr:::.enrRowPipVector(1L, endoapply(gwas, utils::head, 2L)), + set_names(pip, vids) + ) + qtl <- QtlFineMappingResult( + studyName = "q1", + context = "c1", + trait = "g1", + method = "susie", + entry = list(row) + ) + region <- pecotmr:::.enrRowRegion(1L, endoapply(qtl, utils::head, 2L)) + expect_equal(region$pip, set_names(pip, vids)) + expect_equal(region$prior_variance, 1) +}) + +test_that("qtlEnrichmentPipeline warns about narrowed fits on both sides", { + data(gwasFineMappingExample, qtlFineMappingExample) + cnd <- .fitCoverageCondition(qtlEnrichmentPipeline( + gwasFineMappingResult = endoapply( + gwasFineMappingExample, + utils::head, + 2000L + ), + qtlFineMappingResult = endoapply( + qtlFineMappingExample, + utils::head, + 2000L + ), + verbose = FALSE + )) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_match( + conditionMessage(cnd), + "qtlEnrichmentPipeline\\(\\): 2 row\\(s\\)" + ) +}) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index 5b214853..9a000b82 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -1,71 +1,5 @@ context("qtlSumStats") -# =========================================================================== -# Test helpers -# =========================================================================== - -.qtlMakeGenotypeHandle <- function() { - new( - "GenotypeHandle", - path = "/tmp/test", - format = "plink2", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) -} - -.qtlMakeEntryGr <- function( - n = 5, - chr = "chr1", - start_at = 100L, - step = 100L, - with_maf = FALSE -) { - gr <- GenomicRanges::GRanges( - seqnames = rep(chr, n), - ranges = IRanges::IRanges( - start = seq(start_at, by = step, length.out = n), - width = 1L - ) - ) - mcols_list <- list( - SNP = paste0("rs", seq_len(n)), - A1 = rep("A", n), - A2 = rep("G", n), - Z = seq(1.0, by = 0.5, length.out = n), - N = rep(1000L, n) - ) - if (with_maf) { - mcols_list$MAF <- seq(0.05, by = 0.01, length.out = n) - } - S4Vectors::mcols(gr) <- S4Vectors::DataFrame(mcols_list) - gr -} - -.qtlMakeOne <- function( - studyName = "study1", - context = "Cortex", - trait = "ENSG001", - n = 5, - varY = NA_real_, - with_maf = FALSE, - qcInfo = list(), - genome = "hg19" -) { - QtlSumStats( - studyName = studyName, - context = context, - trait = trait, - entry = list(.qtlMakeEntryGr(n, with_maf = with_maf)), - genome = genome, - ldReference = .qtlMakeGenotypeHandle(), - varY = varY, - qcInfo = qcInfo - ) -} - # =========================================================================== # Constructor / validity # =========================================================================== @@ -95,12 +29,13 @@ test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", expect_equal(traitNames(obj), "t1") }) -test_that("QtlSumStats: traitPosition returns NA when no trait position supplied", { +test_that("QtlSumStats: traitPosition is empty when no position was supplied", { obj <- .qtlMakeOne(trait = "ENSG001") # traitPos cannot be inferred from summary statistics, so an unsupplied - # position reports NA rather than a fabricated range. - expect_identical(traitPosition(obj), NA) - expect_identical(traitPosition(obj, "ENSG001"), NA) + # position is an empty GRanges rather than a fabricated range. + expect_s4_class(traitPosition(obj), "GRanges") + expect_length(traitPosition(obj), 0L) + expect_length(traitPosition(obj, "ENSG001"), 0L) }) test_that("QtlSumStats: traitPosition returns the supplied trait position", { @@ -119,8 +54,9 @@ test_that("QtlSumStats: traitPosition returns the supplied trait position", { expect_equal(GenomicRanges::start(tp), 1000L) expect_equal(GenomicRanges::end(tp), 1500L) expect_equal(GenomicRanges::start(traitPosition(obj, "ENSGX")), 1000L) - # a trait not in the collection -> NA - expect_identical(traitPosition(obj, "nope"), NA) + # a trait not in the collection -> an empty GRanges + expect_s4_class(traitPosition(obj, "nope"), "GRanges") + expect_length(traitPosition(obj, "nope"), 0L) }) test_that("QtlSumStats: errors when required args are missing", { @@ -210,19 +146,23 @@ test_that("QtlSumStats: scalar varY is recycled across tuples", { expect_equal(obj$varY, c(1.5, 1.5)) }) -test_that("QtlSumStats: errors when varY length is neither 1 nor n", { - expect_error( - QtlSumStats( - studyName = c("s1", "s2"), - context = c("c1", "c1"), - trait = c("t1", "t1"), - entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), - genome = "hg19", - ldReference = .qtlMakeGenotypeHandle(), - varY = c(1, 2, 3) - ), - "length 1 or length\\(study\\)" - ) +test_that("QtlSumStats: errors when varY or nSample length is not 1 or n", { + for (arg in c("varY", "nSample")) { + expect_error( + exec( + QtlSumStats, + studyName = c("s1", "s2"), + context = c("c1", "c1"), + trait = c("t1", "t1"), + entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), + genome = "hg19", + ldReference = .qtlMakeGenotypeHandle(), + !!arg := c(1, 2, 3) + ), + "length 1 or length\\(study\\)", + info = arg + ) + } }) test_that("QtlSumStats: optional nSample column is absent by default, attached and recycled when supplied", { @@ -241,22 +181,7 @@ test_that("QtlSumStats: optional nSample column is absent by default, attached a expect_true(methods::validObject(obj)) }) -test_that("QtlSumStats: errors when nSample length is neither 1 nor n", { - expect_error( - QtlSumStats( - studyName = c("s1", "s2"), - context = c("c1", "c1"), - trait = c("t1", "t1"), - entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), - genome = "hg19", - ldReference = .qtlMakeGenotypeHandle(), - nSample = c(1, 2, 3) - ), - "length 1 or length\\(study\\)" - ) -}) - -test_that("QtlSumStats: subsetChr preserves the nSample column", { +test_that("QtlSumStats: keepSeqlevels preserves the nSample column", { gr <- .qtlMakeEntryGr(4, chr = "chr1") obj <- QtlSumStats( studyName = "s1", @@ -267,7 +192,7 @@ test_that("QtlSumStats: subsetChr preserves the nSample column", { ldReference = .qtlMakeGenotypeHandle(), nSample = 838 ) - sub <- subsetChr(obj, "chr1") + sub <- GenomeInfoDb::keepSeqlevels(obj, "chr1", pruning.mode = "coarse") expect_equal(as.numeric(sub$nSample), 838) }) @@ -301,20 +226,12 @@ test_that("QtlSumStats: accepts and stores extra per-tuple columns via ...", { # Accessors # =========================================================================== -test_that("sumStats / z / nSamples return values from the single-tuple entry", { +test_that("sumStats / z / sampleSize read the single-tuple entry", { obj <- .qtlMakeOne(n = 4) expect_s4_class(sumStats(obj), "GRanges") expect_equal(length(sumStats(obj)), 4L) expect_equal(z(obj), seq(1.0, by = 0.5, length.out = 4)) - expect_equal(nSamples(obj), rep(1000L, 4)) -}) - -test_that("maf returns NULL when MAF column is absent, vector when present", { - obj_no_maf <- .qtlMakeOne(with_maf = FALSE) - expect_null(maf(obj_no_maf)) - - obj_maf <- .qtlMakeOne(n = 4, with_maf = TRUE) - expect_equal(length(maf(obj_maf)), 4L) + expect_equal(sampleSize(obj), rep(1000L, 4)) }) test_that("nSnps reports the number of variants in the selected entry", { @@ -358,7 +275,7 @@ test_that("accessors require (study, context, trait) when collection has >1 entr ) expect_error( sumStats(obj), - "Pass `study`, `context`, and `trait` to select one" + "Pass `studyName`, `context`, and `trait` to select one" ) expect_s4_class( @@ -384,10 +301,10 @@ test_that("accessors require length-1 selection args", { }) # =========================================================================== -# subsetChr +# Narrowing with the standard verbs # =========================================================================== -test_that("subsetChr keeps only variants on the requested chromosome", { +test_that("keepSeqlevels keeps only the requested chromosome's rows", { # Multi-chromosome entry: 3 on chr1, 2 on chr2. Built in one shot so # the resulting GRanges already shares seqlevels across rows. gr <- GenomicRanges::GRanges( @@ -413,39 +330,47 @@ test_that("subsetChr keeps only variants on the requested chromosome", { ldReference = .qtlMakeGenotypeHandle() ) - chr1_only <- subsetChr(obj, "1") - expect_equal(nSnps(chr1_only), 3L) - - # The "chr" prefix is accepted equivalently. - chr2_only <- subsetChr(obj, "chr2") - expect_equal(nSnps(chr2_only), 2L) + chr1Only <- GenomeInfoDb::keepSeqlevels( + obj, + "chr1", + pruning.mode = "coarse" + ) + expect_equal(nSnps(chr1Only), 3L) + chr2Only <- GenomeInfoDb::keepSeqlevels( + obj, + "chr2", + pruning.mode = "coarse" + ) + expect_equal(nSnps(chr2Only), 2L) }) -test_that("subsetChr drops the element when no variants on that chromosome", { - # subsetChr is now the whole-seqname case of subsetRegion, which DROPS - # elements that trim to nothing rather than keeping an empty one. After - # the seqname split an element belongs to exactly one chromosome, so - # "kept but empty" no longer describes anything real. +test_that("a range subset that keeps no row leaves an empty collection", { obj <- .qtlMakeOne(n = 4) - empty <- subsetChr(obj, "22") + # A window on the collection's own chromosome, past its variants. + empty <- IRanges::subsetByOverlaps( + obj, + GenomicRanges::GRanges("chr1:90000000-90000100") + ) expect_equal(nrow(empty), 0L) expect_equal(length(empty), 0L) - # The collection-level state survives even when nothing is left. + # The collection-level state survives even when nothing is left; no row + # is left to use the reference, so none is reported. expect_equal( unname(GenomeInfoDb::genome(empty)), unname(GenomeInfoDb::genome(obj)) ) - expect_identical(ldReference(empty), ldReference(obj)) + expect_identical(empty@ldReference, obj@ldReference) + expect_identical(ldReference(empty), list()) }) -test_that("subsetChr keeps class-level slots (genome, ldReference, qcInfo)", { - obj <- .qtlMakeOne(qcInfo = list(step1 = "ok")) - res <- subsetChr(obj, "1") +test_that("keepSeqlevels keeps the collection-level slots", { + obj <- .qtlMakeOne(qcOptions = list(step1 = "ok")) + res <- GenomeInfoDb::keepSeqlevels(obj, "chr1", pruning.mode = "coarse") expect_equal( unname(GenomeInfoDb::genome(res)), unname(GenomeInfoDb::genome(obj)) ) - expect_equal(qcInfo(res), qcInfo(obj)) + expect_equal(qcOptions(res), qcOptions(obj)) expect_identical(ldReference(res), ldReference(obj)) }) @@ -484,7 +409,8 @@ test_that("QtlSumStats: ldReference is optional (NULL for LD-free workflows)", { entry = list(.qtlMakeEntryGr(1)), genome = "hg19" ) # ldReference omitted - expect_null(ldReference(obj)) + expect_identical(ldReference(obj), list()) + expect_true(is.na(obj$ldReference)) expect_output(show(obj), "none \\(LD-free\\)") }) @@ -593,7 +519,7 @@ test_that("no traitPos -> no distance columns; existing distance is preserved", # === combineQtlSumStats() === -test_that("combineQtlSumStats() row-binds collections and keeps NULL sketches", { +test_that("combineQtlSumStats() row-binds collections and LD-free rows", { data(qtlSumStatsExample) a <- qtlSumStatsExample b <- a @@ -602,17 +528,35 @@ test_that("combineQtlSumStats() row-binds collections and keeps NULL sketches", out <- combineQtlSumStats(a, b) expect_s4_class(out, "QtlSumStats") expect_equal(nrow(out), nrow(a) + nrow(b)) - expect_identical(as.list(out), c(as.list(a), as.list(b))) + expect_identical(unname(as.list(out)), unname(c(as.list(a), as.list(b)))) + # The combined rows are named from their own tuples; mcols<- left `b` + # with the names of the study it was copied from. + expect_identical( + names(out), + c("study1|brain|ENSG_example", "study1_b|brain|ENSG_example") + ) expect_equal( unname(GenomeInfoDb::genome(out)), unname(GenomeInfoDb::genome(a)) ) - a2 <- a - a2@ldReference <- NULL - b2 <- b - b2@ldReference <- NULL - expect_null(ldReference(combineQtlSumStats(a2, b2))) + # Both parts read the one panel, so it is stored once for every row. + expect_identical(ldReference(out), ldReference(a)) + expect_equal(unique(out$ldReference), names(ldReference(out))) + + ldFree <- function(x) { + QtlSumStats( + studyName = x$study, + context = x$context, + trait = x$trait, + entry = as.list(x), + genome = unname(GenomeInfoDb::genome(x))[[1L]] + ) + } + expect_identical( + ldReference(combineQtlSumStats(ldFree(a), ldFree(b))), + list() + ) }) @@ -662,9 +606,12 @@ test_that("existing mcols survive the trait-distance annotation", { }) test_that("an entry with no variants is returned untouched", { + # A variant set with no ranges has no positions to take a distance from. gr0 <- GenomicRanges::GRanges() tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(5L, width = 1L)) - expect_equal(length(pecotmr:::.qssAppendTraitDist(1L, list(gr0), tp)), 0L) + out <- pecotmr:::.qssAppendTraitDist(1L, list(gr0), tp) + expect_s4_class(out, "GRanges") + expect_length(out, 0L) }) test_that("validity names the identity columns that are missing", { @@ -686,10 +633,184 @@ test_that(".appendTraitDistances is a no-op without a trait position", { expect_identical(pecotmr:::.appendTraitDistances(entry, NULL), entry) }) -test_that(".qssAppendTraitDist returns an empty entry untouched", { - # A variant set with no ranges has no positions to take a distance from. - empty <- GenomicRanges::GRanges() - out <- pecotmr:::.qssAppendTraitDist(1L, list(empty), NULL) - expect_s4_class(out, "GRanges") - expect_length(out, 0L) +test_that("QtlSumStats records each tuple's window and its origin", { + data(qtlSumStatsExample) + q <- qtlSumStatsExample + g <- q[[1L]] + chrom <- as.character(GenomicRanges::seqnames(g))[[1L]] + lo <- GenomicRanges::start(g)[[10L]] + hi <- GenomicRanges::start(g)[[150L]] + build <- function(...) { + QtlSumStats( + studyName = q$study, + context = q$context, + trait = q$trait, + entry = list(g), + genome = unique(GenomeInfoDb::genome(q)), + ... + ) + } + # Without one, a tuple's window is the span it was built with. + plain <- build() + expect_false(plain$regionGiven) + expect_identical(as.character(plain$region), as.character(range(g))) + # A window drops the variants outside it, with a warning, and is given. + window <- str_c(chrom, ":", lo, "-", hi) + expect_warning( + inside <- build(region = GenomicRanges::GRanges(window)), + "variant(s) lie outside their tuple's `region`", + fixed = TRUE + ) + expect_true(inside$regionGiven) + expect_identical(as.character(inside$region), window) + expect_identical(length(inside[[1L]]), 141L) + # Read from a BED file, its start is 0-based. + bedPath <- withr::local_tempfile(fileext = ".bed") + writeLines(str_c(chrom, "\t", lo - 1L, "\t", hi), bedPath) + bed <- suppressWarnings(build(region = bedPath)) + expect_identical(as.character(bed$region), window) + # One window for every tuple, or one per tuple. + expect_error( + build(region = GenomicRanges::GRanges(c(window, window))), + "one window, or one per tuple" + ) +}) + +test_that("a cisWindow narrows each selected tuple to its trait's window", { + data(qtlSumStatsExample) + q <- qtlSumStatsExample + g <- q[[1L]] + chrom <- as.character(GenomicRanges::seqnames(g))[[1L]] + tp <- GenomicRanges::GRanges( + chrom, + IRanges::IRanges(GenomicRanges::start(g)[[80L]], width = 1L) + ) + build <- function(...) { + QtlSumStats( + studyName = q$study, + context = q$context, + trait = q$trait, + entry = list(g), + genome = unique(GenomeInfoDb::genome(q)), + ... + ) + } + x <- build(traitPos = tp) + expect_identical(pecotmr:::.qssApplyCisWindow(x, NULL, "f", 1L), x) + cis <- pecotmr:::.qssApplyCisWindow(x, 5000, "f", 1L) + expect_true(cis$regionGiven) + expect_identical( + GenomicRanges::start(cis$region), + GenomicRanges::start(tp) - 5000L + ) + expect_true(all( + abs(GenomicRanges::start(cis[[1L]]) - GenomicRanges::start(tp)) <= 5000L + )) + # The cis window keeps inside the window the tuple already had. + edge <- GenomicRanges::GRanges( + chrom, + IRanges::IRanges( + GenomicRanges::start(tp), + GenomicRanges::end(g)[[200L]] + ) + ) + clipped <- pecotmr:::.qssApplyCisWindow( + suppressWarnings(build(traitPos = tp, region = edge)), + 5000, + "f", + 1L + ) + expect_identical( + GenomicRanges::start(clipped$region), + GenomicRanges::start(tp) + ) + # A selected tuple with no trait position has no cis window; one the + # selection leaves out is left alone. + bare <- build() + expect_error( + pecotmr:::.qssApplyCisWindow( + bare, + 5000, + "fineMappingPipeline", + 1L + ), + "fineMappingPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) + expect_identical( + pecotmr:::.qssApplyCisWindow(bare, 5000, "f", integer(0)), + bare + ) +}) + +test_that(".clipWindows keeps nothing of a window that misses its row's", { + windows <- GenomicRanges::GRanges( + c("chr1", "chr1", "chr2"), + IRanges::IRanges(c(100L, 100L, 100L), c(200L, 200L, 200L)) + ) + regions <- GenomicRanges::GRanges( + c("chr1", "chr1", "chr1"), + IRanges::IRanges(c(150L, 300L, 100L), c(400L, 400L, 200L)) + ) + clipped <- pecotmr:::.clipWindows(windows, regions) + expect_identical(as.character(clipped)[[1L]], "chr1:150-200") + expect_identical(GenomicRanges::width(clipped)[2:3], c(0L, 0L)) +}) + +# =========================================================================== +# metadata, qcOptions and a tabular extraCols +# =========================================================================== + +test_that("QtlSumStats() takes extra columns as a DataFrame", { + obj <- QtlSumStats( + studyName = c("s1", "s2"), + context = c("c1", "c1"), + trait = c("t1", "t1"), + entry = list(.qtlMakeEntryGr(2), .qtlMakeEntryGr(2)), + genome = "hg19", + ldReference = .qtlMakeGenotypeHandle(), + extraCols = S4Vectors::DataFrame(cohort = c("UKB", "FinnGen")) + ) + expect_equal(obj$cohort, c("UKB", "FinnGen")) +}) + +test_that("QtlSumStats() keeps the caller's metadata and QC options", { + obj <- .qtlMakeOne(qcOptions = list(step1 = "ok")) + expect_equal(qcOptions(obj), list(step1 = "ok")) + withMeta <- QtlSumStats( + studyName = "s1", + context = "c1", + trait = "t1", + entry = list(.qtlMakeEntryGr(2)), + genome = "hg19", + ldReference = .qtlMakeGenotypeHandle(), + metadata = list(source = "unit test") + ) + expect_equal(S4Vectors::metadata(withMeta), list(source = "unit test")) +}) + +# =========================================================================== +# sumStats(annotateSignificance =) +# =========================================================================== + +test_that("sumStats(annotateSignificance=) adds a derived logical mcol", { + x <- .qapDefaultFixture + r <- qtlAssociationPostprocess(x, methods = "permutation") + gr <- sumStats( + r, + studyName = "s", + context = "brain", + trait = "g1", + annotateSignificance = "permutation" + ) + expect_true("significant" %in% names(S4Vectors::mcols(gr))) + expect_type(S4Vectors::mcols(gr)$significant, "logical") + # matches the permutation rule P < p_nominal_threshold[gene 1] + thr1 <- as.numeric(r$p_nominal_threshold)[1] + exp1 <- if (is.na(thr1)) { + rep(FALSE, length(gr)) + } else { + S4Vectors::mcols(gr)$P < thr1 + } + expect_equal(S4Vectors::mcols(gr)$significant, exp1) }) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index 2c48d991..9b4fe7b7 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -1,30 +1,19 @@ -context("SS-TWAS: weights, pipeline, and omnibus combination") - -# Previous TwasWeights-class tests used the legacy constructor -# `TwasWeights(weights = list(...), variantIds = ..., standardized = ...)`. -# The new `TwasWeights` is a DFrame collection class with (study, -# context, trait, method, entry) columns where each entry is a -# `TwasWeightsRow` S4 object carrying weights / fits / cvResult. -# Class-shape tests for the new collection should live alongside the -# pipeline tests and assert via accessors (`weights`, `studyName`, -# `cvResult`, etc.) — not against legacy slot shapes. -# -# `twasAnalysis()` was collapsed into the unified `twasZ()` dispatcher -# (task #37); its tests are removed here. -# `twasWeightsSumstatPipeline()` was removed without replacement in the -# S4 refactor (twasWeightsPipeline now dispatches directly on -# `QtlSumStats` / `QtlDataset` / `MultiStudyQtlDataset`). -# -# What remains: tests of the internal SuSiE-RSS weight extractors that -# are still present in `R/twasWeights.R` (`.susieRssExtractWeights`, -# `susieRssWeights`, `susieInfRssWeights`). +context("regularized_regression - wrappers") + +# Tests of R/regularizedRegressionWrappers.R: the mr.mash helpers, the weight +# wrappers' engine arguments and fit retention, and their real-fit coverage. +# Each method's own tests live in the matching test_rr*.R topic file. # ============================================================================= -# SuSiE-RSS weight extraction +# mrmashWeights fit retention # ============================================================================= -test_that("mrmashWeights fitRetention: slim omits the full fit, full keeps it", { +test_that("mrmashWeights retains nothing, the prior parts, or the full fit", { skip_if_not_installed("mr.mashr") + # The slim payload is exactly what fineMappingPipeline needs to rebuild the + # mvSuSiE reweighted mixture prior (w0 -> rescaleCovW0, original $U) and + # the residual variance (V); the heavy mu1 coefficient matrix is not + # retained. fakeFit <- list(w0 = c(a_1 = 0.5, a_2 = 0.5), V = diag(2)) ddpm <- list(U = list(a = diag(2))) # Mock coef extraction so we exercise only the retain payload logic, not a @@ -41,10 +30,17 @@ test_that("mrmashWeights fitRetention: slim omits the full fit, full keeps it", ), "fit" ) + expect_true(is.list(fitSlim)) expect_setequal(names(fitSlim), c("dataDrivenPriorMatrices", "w0", "V")) expect_null(fitSlim$fit) # slim: no full fit expect_identical(fitSlim$dataDrivenPriorMatrices, ddpm) expect_identical(fitSlim$w0, fakeFit$w0) + expect_identical(fitSlim$V, fakeFit$V) + # The default ("none") leaves the weights free of the fit attribute. + expect_null(attr( + mrmashWeights(mrmashFit = fakeFit, dataDrivenPriorMatrices = ddpm), + "fit" + )) fitFull <- attr( mrmashWeights( @@ -59,13 +55,10 @@ test_that("mrmashWeights fitRetention: slim omits the full fit, full keeps it", expect_identical(fitFull$w0, fakeFit$w0) # slim fields still present }) - # ============================================================================= -# Two-stage SuSiE-RSS fitting +# mr.mash helpers: computeW0 # ============================================================================= -# === Tests migrated from test_mrmashWrapper.R (mr.mash + glasso/glmnet coef helpers) === - test_that("computeW0 returns uniform weights when ncomps == 1", { Bhat <- matrix(c(1, 0, 0, 2, 0, 0), nrow = 3, ncol = 2) result <- pecotmr:::computeW0(Bhat, ncomps = 1) @@ -96,7 +89,7 @@ test_that("computeW0 distributes weight based on nonzero rows when ncomps > 1", }) # ========================================================================= -# mrmashWrapper.R: rescaleCovW0 (lines 300-329) +# rescaleCovW0 # ========================================================================= test_that("rescaleCovW0 removes null component and renormalizes", { @@ -137,7 +130,7 @@ test_that("rescaleCovW0 groups correctly by prior group prefix", { }) # ========================================================================= -# mrmashWrapper.R: computeGrid (mr.mash's own exported grid builder) +# computeGrid (mr.mash's own exported grid builder) # ========================================================================= test_that("computeGrid is mr.mash's grid, not a reimplementation of it", { @@ -148,28 +141,19 @@ test_that("computeGrid is mr.mash's grid, not a reimplementation of it", { set.seed(3) bhat <- matrix(rnorm(20, sd = 2), nrow = 10, ncol = 2) sbhat <- matrix(abs(rnorm(20, mean = 0.5, sd = 0.1)), nrow = 10, ncol = 2) + grid <- pecotmr:::computeGrid(bhat, sbhat) expect_equal( - pecotmr:::computeGrid(bhat, sbhat), + grid, mr.mashr::autoselect.mixsd( list(Bhat = bhat, Shat = sbhat), mult = sqrt(2) )^2 ) + expect_true(all(grid > 0)) # The ported floor would have been 10^2 times this one, since the grid # scales variances. ported <- min(sbhat) - expect_lt(min(pecotmr:::computeGrid(bhat, sbhat)), ported^2) -}) - - -test_that("compute_grid produces a valid grid from summary statistics", { - set.seed(42) - bhat <- matrix(rnorm(20, sd = 2), nrow = 10, ncol = 2) - sbhat <- matrix(abs(rnorm(20, mean = 0.5, sd = 0.1)), nrow = 10, ncol = 2) - result <- pecotmr:::computeGrid(bhat, sbhat) - expect_true(is.numeric(result)) - expect_true(length(result) > 0) - expect_true(all(result > 0)) + expect_lt(min(grid), ported^2) }) @@ -182,7 +166,7 @@ test_that("compute_grid handles NA and zero sbhat values", { }) # ========================================================================= -# mrmashWrapper.R: mrmashWrapper input validation (lines 99-130) +# mrmashWrapper input validation # ========================================================================= # Note: Cannot mock requireNamespace via local_mocked_bindings because it is a @@ -273,7 +257,7 @@ test_that("mrmashWrapper warns when Y has missing and B_init_method is glasso", }) # ========================================================================= -# mrmashWrapper.R: computeCoefficientsGlasso (lines 211-240) +# computeCoefficientsGlasso # ========================================================================= test_that("computeCoefficientsGlasso runs without Xnew", { @@ -289,7 +273,6 @@ test_that("computeCoefficientsGlasso runs without Xnew", { X, Y, standardize = FALSE, - numThreads = 1, Xnew = NULL ) expect_true("Bhat" %in% names(result)) @@ -314,7 +297,6 @@ test_that("computeCoefficientsGlasso runs with Xnew", { X, Y, standardize = FALSE, - numThreads = 1, Xnew = Xnew ) expect_true("Yhat_new" %in% names(result)) @@ -324,9 +306,30 @@ test_that("computeCoefficientsGlasso runs with Xnew", { }) # ========================================================================= -# mrmashWrapper.R: computeCoefficientsUnivGlmnet (lines 243-281) +# computeCoefficientsUnivGlmnet # ========================================================================= +test_that("computeCoefficientsUnivGlmnet gives the same fits on two workers", { + skip_if_not_installed("glmnet") + skip_on_os("windows") + set.seed(5) + X <- matrix(rnorm(60 * 5), 60, 5) + Y <- matrix(rnorm(60 * 2), 60, 2, dimnames = list(NULL, c("a", "b"))) + fit <- function(bp) { + pecotmr:::computeCoefficientsUnivGlmnet( + X, + Y, + alpha = 0.5, + standardize = FALSE, + BPPARAM = bp + ) + } + expect_equal( + fit(BiocParallel::SerialParam(RNGseed = 9L)), + fit(BiocParallel::MulticoreParam(2, RNGseed = 9L)) + ) +}) + test_that("computeCoefficientsUnivGlmnet runs without Xnew", { skip_if_not_installed("glmnet") set.seed(42) @@ -397,22 +400,22 @@ test_that("computeCoefficientsUnivGlmnet handles NA in Y", { }) # ========================================================================= -# mrmashWrapper.R: mrmashWrapper seed warning (line 107-108) +# mrmashWrapper seed message # ========================================================================= # Note: Cannot mock base::exists() via local_mocked_bindings. -# The seed-check message on line 107-108 would require removing .Random.seed -# from the global environment, which is not safe to do in tests. +# The seed-check message would require removing .Random.seed from the global +# environment, which is not safe to do in tests. # ============================================================================= # Real-fit coverage for the solver wrappers in R/regularizedRegressionWrappers.R # ----------------------------------------------------------------------------- -# The fine-mapping / TWAS pipelines MOCK these wrappers, so their bodies are -# otherwise untested. Here we drive each wrapper on a SMALL real fixture and -# assert the return shape (weight length == #variants; matrix for multivariate; -# attr(.,"fit") unless fitRetention is "none"). MCMC iterations kept tiny. -# fsusieWeights and the mock-based mrmash/mvsusie payload tests live in -# test_rrMrmashMvsusie.R and are not duplicated here. +# The fine-mapping / TWAS pipelines MOCK these wrappers. Here we drive the +# wrappers on a SMALL real fixture and assert the return shape (weight length +# == #variants; matrix for multivariate; attr(.,"fit") unless fitRetention is +# "none"). MCMC iterations kept tiny. Each method's shape and signal-recovery +# tests live in its test_rr*.R topic file; fsusieWeights is tested in +# test_fineMappingWrappers.R. # ============================================================================= # (Shared .rrwXy / .rrwStatLd / .rrwMulti fixtures live in helper-rrwFixtures.R @@ -528,8 +531,7 @@ test_that("mr.mash glmnet initialisation routes through fitGlmnetCv", { gl <- .rrw_captureGlmnet(computeCoefficientsGlasso( f$X, Y, - standardize = TRUE, - numThreads = 1L + standardize = TRUE )) expect_equal(gl$family, "mgaussian") expect_equal(gl$alpha, 1) @@ -550,26 +552,6 @@ test_that("mr.mash glmnet initialisation routes through fitGlmnetCv", { expect_false(is_in("parallel", names(uv))) }) -test_that("lassoWeights / enetWeights (glmnet) return length-p weights", { - skip_if_not_installed("glmnet") - f <- .rrwXy() - expect_length(as.numeric(lassoWeights(f$X, f$y)), f$p) - expect_length(as.numeric(enetWeights(f$X, f$y)), f$p) -}) - -test_that("scadWeights / mcpWeights (ncvreg) return length-p weights", { - skip_if_not_installed("ncvreg") - f <- .rrwXy() - expect_length(as.numeric(scadWeights(f$X, f$y)), f$p) - expect_length(as.numeric(mcpWeights(f$X, f$y)), f$p) -}) - -test_that("l0learnWeights returns length-p weights", { - skip_if_not_installed("L0Learn") - f <- .rrwXy() - expect_length(as.numeric(l0learnWeights(f$X, f$y)), f$p) -}) - test_that("mrashWeights returns length-p weights and can retain the fit", { skip_if_not_installed("susieR") skip_if_not_installed("glmnet") @@ -588,7 +570,10 @@ test_that("qgg Bayes-alphabet weights (N/L/A/C/R) return length-p weights", { skip_if_not_installed("qgg") f <- .rrwXy() mc <- list(nit = 200, nburn = 20, nthin = 1) - expect_length(exec(bayesNWeights, !!!c(list(f$X, f$y), mc)), f$p) + wN <- exec(bayesNWeights, !!!c(list(f$X, f$y), mc)) + expect_length(wN, f$p) + expect_true(is.numeric(wN)) + expect_true(all(is.finite(wN))) expect_length(exec(bayesLWeights, !!!c(list(f$X, f$y), mc)), f$p) expect_length(exec(bayesAWeights, !!!c(list(f$X, f$y), mc)), f$p) expect_length(exec(bayesCWeights, !!!c(list(f$X, f$y), mc)), f$p) @@ -650,37 +635,6 @@ test_that("bayesAlphabetWeights forwards every MCMC control to gbayes", { expect_equal(seen$nthin, 7) }) -test_that("bayesAlphabetWeights validates matching row counts before fitting", { - skip_if_not_installed("qgg") - f <- .rrwXy() - expect_error( - bayesAlphabetWeights(f$X, f$y[-1], method = "bayesN"), - "y.*Must have length 50" - ) - expect_error( - bayesAlphabetWeights( - f$X, - f$y, - method = "bayesN", - Z = matrix(1, f$n - 1, 1) - ), - "Z.*Must have exactly 50 rows" - ) -}) - -test_that("bayesBWeights / bLassoWeights (BGLR) return length-p weights", { - skip_if_not_installed("BGLR") - f <- .rrwXy() - expect_length( - bayesBWeights(f$X, f$y, nIter = 200, burnIn = 20, thin = 1), - f$p - ) - expect_length( - bLassoWeights(f$X, f$y, nIter = 200, burnIn = 20, thin = 1), - f$p - ) -}) - test_that("dprVbWeights returns length-p weights and retains the fit", { skip_if_not_installed("RcppDPR") f <- .rrwXy() @@ -692,7 +646,15 @@ test_that("dprVbWeights returns length-p weights and retains the fit", { test_that("dprGibbsWeights returns length-p weights", { skip_if_not_installed("RcppDPR") f <- .rrwXy() - invisible(capture.output(w <- dprGibbsWeights(f$X, f$y, sStep = 200))) + # Capturing the DPR engine's progress bar is what is slow, not sampling. + invisible(capture.output( + w <- dprGibbsWeights( + f$X, + f$y, + sStep = 200, + methodArgs = DprOptions(show_progress = FALSE) + ) + )) expect_length(w, f$p) }) @@ -703,7 +665,7 @@ test_that("dprAdaptiveGibbsWeights returns length-p weights", { w <- dprAdaptiveGibbsWeights( f$X, f$y, - methodArgs = DprOptions(s_step = 100) + methodArgs = DprOptions(s_step = 100, show_progress = FALSE) ) )) expect_length(w, f$p) @@ -724,66 +686,6 @@ test_that("mrmashWeights fits from (X, Y) and returns p x K weights", { }) -# ----------------------------- RSS solvers (C++) ---------------------------- - -test_that("lassosumRss returns a p x nlambda beta matrix", { - f <- .rrwStatLd() - out <- lassosumRss(f$stat$b, f$LD, f$n) - expect_equal(nrow(out$beta), f$p) - expect_equal(ncol(out$beta), length(out$lambda)) - expect_length(out$conv, length(out$lambda)) -}) - -test_that("penalizedRss traces a solution path for MCP / SCAD / L0", { - f <- .rrwStatLd() - for (pen in c("MCP", "SCAD")) { - out <- penalizedRss(f$stat$b, f$LD, f$n, penalty = pen) - expect_equal(nrow(out$beta), f$p) - } - outL0 <- penalizedRss( - f$stat$b, - f$LD, - f$n, - penalty = "L0", - lambda0 = 0.01, - lambda = c(0) - ) - expect_equal(nrow(outL0$beta), f$p) -}) - -test_that("prsCs returns posterior betaEst of length p", { - f <- .rrwStatLd() - out <- prsCs(f$stat$b, f$LD, f$n, nIter = 100, nBurnin = 20, thin = 1) - expect_length(out$betaEst, f$p) - expect_true(all(is.finite(out$betaEst))) -}) - -test_that("sdpr returns betaEst of length p", { - f <- .rrwStatLd() - out <- sdpr( - f$stat$b, - f$LD, - f$n, - iter = 100, - burn = 20, - thin = 1, - verbose = FALSE - ) - expect_length(out$betaEst, f$p) -}) - -test_that("RSS solvers validate their R-matrix / sample-size / length inputs", { - f <- .rrwStatLd() - # A list (the old block-list contract) is now rejected: R must be a matrix. - expect_error(prsCs(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") - expect_error(lassosumRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") - expect_error(penalizedRss(f$stat$b, list(blk1 = f$LD), f$n), "as a matrix") - expect_error(prsCs(f$stat$b, f$LD, -1), "sample size") - expect_error(prsCs(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") - expect_error(sdpr(f$stat$b[-1], f$LD, f$n), "bhat.*Must have length 6") - expect_error(sdpr(f$stat$b, f$LD, f$n, M = 2), "at least 4") -}) - # --------------------------- RSS weight wrappers ---------------------------- test_that("lassosumRssWeights returns length-p weights and records the selection", { @@ -797,18 +699,19 @@ test_that("lassosumRssWeights returns length-p weights and records the selection ) }) -test_that("scadRssWeights / mcpRssWeights / l0learnRssWeights return length-p weights", { - f <- .rrwStatLd() - 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) + # At mr.ash.rss's own tol (1e-8) this fit takes some 10,000 iterations; + # what is retained does not depend on how tightly it converged. + opts <- MrashRssOptions(tol = 1e-4) + none <- mrashRssWeights(f$stat, f$ldReference, methodArgs = opts) expect_null(attr(none, "fit")) - slim <- mrashRssWeights(f$stat, f$ldReference, fitRetention = "slim") + slim <- mrashRssWeights( + f$stat, + f$ldReference, + fitRetention = "slim", + methodArgs = opts + ) expect_equal(as.numeric(slim), as.numeric(none)) expect_equal(as.numeric(attr(slim, "fit")$mu1), as.numeric(none)) }) @@ -822,6 +725,8 @@ test_that("the raw RSS solvers are internal behind their weight adapters", { "prsCsWeights", "sdprWeights", "lassosumRssWeights", + "enetRssWeights", + "ridgeRssWeights", "scadRssWeights", "mcpRssWeights", "l0learnRssWeights" @@ -834,6 +739,35 @@ test_that("the raw RSS solvers are internal behind their weight adapters", { expect_error(PenalizedRssOptions(notAnOption = 1), "unknown argument") }) +test_that("PenalizedRssOptions refuses the settings its wrappers own", { + for (nm in c( + "penalty", + "alpha", + "gamma", + "lambda0", + "lambda2", + "maxSwaps" + )) { + expect_error( + exec(PenalizedRssOptions, !!!set_names(list(1), nm)), + str_c(nm, " is supplied by pecotmr"), + label = nm + ) + } + # The rest stay tunable: `lambda` is the only route to the path for the + # wrappers that take none. + expect_no_error( + PenalizedRssOptions(lambda = c(0.1, 0.01), thr = 1e-6, maxiter = 500) + ) +}) + +test_that("GlmnetOptions points alpha at the wrapper that takes it", { + expect_error( + GlmnetOptions(alpha = 0.3), + "alpha is supplied by pecotmr.*enetWeights' own `alpha`" + ) +}) + 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. @@ -946,46 +880,79 @@ test_that("the RSS solvers run on a factor of the LD as on the LD itself", { 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)) + # lassosum is the lasso at alpha = 1; below it, the elastic net and ridge. + # L0L2 adds its fixed ridge weight lambda2, which both routes apply in + # the shared thresholding, swaps and objective. + cases <- data.frame( + penalty = c( + "lasso", + "lasso", + "lasso", + "MCP", + "MCP", + "SCAD", + "L0", + "L0L2", + "L0L2" + ), + alpha = c(1, 0.5, 0, 1, 0.5, 1, 1, 1, 1), + lambda2 = c(0, 0, 0, 0, 0, 0, 0, 0.05, 0.5) + ) 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")) { + for (k in seq_len(nrow(cases))) { args <- list( lambdaR = lambda, - penaltyStr = pen, + penaltyStr = cases$penalty[[k]], gamma = 3.7, - alpha = 1, + alpha = cases$alpha[[k]], lambda0 = 0.001, - lambda2 = 0, + lambda2 = cases$lambda2[[k]], thr = 1e-6, maxiter = 1000L, maxSwaps = 10L ) + label <- str_c( + cases$penalty[[k]], + ", alpha = ", + cases$alpha[[k]], + ", lambda2 = ", + cases$lambda2[[k]] + ) 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 + label = label ) expect_equal( exec(pecotmr:::penalizedRssFactorCpp, z, F, s, !!!args), dense, tolerance = 1e-8, - label = pen + label = label ) } } + # The two routes agreeing would not show lambda2 is applied at all; the + # fit with it must differ from the one without. + l0Fit <- function(lambda2) { + pecotmr:::penalizedRssFactorCpp( + z, + F, + 0.2, + lambdaR = lambda, + penaltyStr = "L0L2", + gamma = 3.7, + alpha = 1, + lambda0 = 0.001, + lambda2 = lambda2, + thr = 1e-6, + maxiter = 1000L, + maxSwaps = 10L + )$beta + } + expect_false(isTRUE(all.equal(l0Fit(0.5), l0Fit(0)))) }) test_that("SDPR on a factor of the LD draws as it does on the matrix", { @@ -1014,8 +981,10 @@ test_that("SDPR on a factor of the LD draws as it does on the matrix", { M = 50L, a0k = 0.5, b0k = 0.5, - iter = 200L, - burn = 50L, + # Every sampler step runs on each iteration, so a short chain already + # exercises burn-in, thinning and the draws the routes must share. + iter = 100L, + burn = 25L, thin = 5L, numThreads = 1L, optLlk = 1L, @@ -1048,31 +1017,6 @@ test_that("SDPR on a factor of the LD draws as it does on the matrix", { ) }) -test_that("prsCsWeights and sdprWeights take (stat, ldReference)", { - f <- .rrwStatLd() - expect_length( - prsCsWeights( - f$stat, - f$ldReference, - methodArgs = PrsCsOptions(nIter = 100, nBurnin = 20, thin = 1) - ), - f$p - ) - expect_length( - sdprWeights( - f$stat, - f$ldReference, - methodArgs = SdprOptions( - iter = 100, - burn = 20, - thin = 1, - verbose = FALSE - ) - ), - f$p - ) -}) - 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 @@ -1132,19 +1076,24 @@ test_that("RSS weights read a genotype panel's LD as they read the matrix", { label = nm ) } - # mr.ash.rss takes only a matrix, formed from the panel. + # mr.ash.rss takes only a matrix, formed from the panel. A looser tol + # than its own 1e-8 (some 7,000 iterations here) converges in about 100; + # the two routes fit the same matrix whatever the tolerance. + mrashOpts <- MrashRssOptions(tol = 1e-4) expect_equal( - mrashRssWeights(d$stat, d$panel), - mrashRssWeights(d$stat, d$ldMatrix), + mrashRssWeights(d$stat, d$panel, methodArgs = mrashOpts), + mrashRssWeights(d$stat, d$ldMatrix, methodArgs = mrashOpts), 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. + # seeded chain lands on the matrix route's. A 50-component mixture + # rather than the default 1000 keeps the chains quick. for (optLlk in 1:2) { opts <- SdprOptions( iter = 100, burn = 20, thin = 1, + M = 50, optLlk = optLlk, verbose = FALSE, seed = 1L @@ -1194,7 +1143,15 @@ test_that("mrashRssWeights defaults to mr.ash's own prior grid", { fit$data$sa2 ) f <- .rrwStatLd() - expect_length(mrashRssWeights(f$stat, f$ldReference), f$p) + # A looser tol than mr.ash.rss's 1e-8, which takes some 10,000 iterations. + expect_length( + mrashRssWeights( + f$stat, + f$ldReference, + methodArgs = MrashRssOptions(tol = 1e-4) + ), + f$p + ) # With b, seb and varY the unstandardized statistics set the scale. z <- f$stat$z shat <- f$stat$seb @@ -1205,21 +1162,6 @@ test_that("mrashRssWeights defaults to mr.ash's own prior grid", { ) }) -test_that("mrashRssWeights returns posterior-mean weights of length p", { - skip_if_not_installed("susieR") - f <- .rrwStatLd() - w <- mrashRssWeights( - f$stat, - f$ldReference, - varY = 1, - sigma2E = 1, - s0 = c(0, 0.01, 0.1, 0.5, 1), - w0 = rep(1 / 5, 5) - ) - expect_length(w, f$p) - expect_true(all(is.finite(w))) -}) - test_that("mrmashRssWeights fits mr.mash.rss and returns p x K weights", { skip_if_not_installed("mr.mashr") @@ -1356,7 +1298,7 @@ test_that("buildMrmashPriorMatrices errors without canonical or data-driven prio # =========================================================================== -# mr.mash weight tests (relocated from test_rrMrmashMvsusie.R) +# mrmashWeights and the mr.mash engine arguments # =========================================================================== # ---- mrmashWeights ---- @@ -1387,41 +1329,6 @@ test_that("mrmashWeights errors when X and Y are NULL and fit is NULL", { ) }) -test_that("mrmashWeights retaining attaches {dataDrivenPriorMatrices, w0, V}", { - skip_if_not( - requireNamespace("mr.mashr", quietly = TRUE), - "mr.mashr not installed" - ) - # These are exactly the parts fineMappingPipeline needs to rebuild the - # mvSuSiE reweighted mixture prior (w0 -> rescaleCovW0, original $U) and the - # residual variance (V); the heavy mu1 coefficient matrix is not retained. - ddpm <- list(U = list(comp = diag(2))) - fakeFit <- structure( - list(w0 = c(null = 0.4, comp_grid1 = 0.6), V = diag(2) * 2), - class = "mr.mash" - ) - fakeCoef <- matrix(0.1, nrow = 5, ncol = 2) - local_mocked_bindings( - coef.mr.mash = function(object, ...) fakeCoef, - .package = "mr.mashr" - ) - w <- mrmashWeights( - mrmashFit = fakeFit, - dataDrivenPriorMatrices = ddpm, - fitRetention = "slim" - ) - fit <- attr(w, "fit") - expect_true(is.list(fit)) - expect_identical(fit$dataDrivenPriorMatrices, ddpm) - expect_identical(fit$w0, fakeFit$w0) - expect_identical(fit$V, fakeFit$V) - # The default ("none") leaves the weights free of the fit attribute. - expect_null(attr( - mrmashWeights(mrmashFit = fakeFit, dataDrivenPriorMatrices = ddpm), - "fit" - )) -}) - test_that("MCMC / optimiser control arguments are guarded", { expect_error( bayesBWeights(NULL, NULL, nIter = 0), @@ -1452,18 +1359,9 @@ test_that("MCMC / optimiser control arguments are guarded", { "nfolds.*Must be >= 1" ) expect_error( - computeCoefficientsGlasso(NULL, NULL, standardize = NA, numThreads = 1), + computeCoefficientsGlasso(NULL, NULL, standardize = NA), "standardize.*May not be NA" ) - expect_error( - computeCoefficientsGlasso( - NULL, - NULL, - standardize = TRUE, - numThreads = 1.5 - ), - "numThreads.*integerish" - ) }) test_that("RSS solver control arguments are guarded", { @@ -1539,7 +1437,7 @@ test_that("MrmashPriorParam nests each engine function's own arguments", { expect_length(MrmashExpandCovsOptions(), 0L) }) -test_that("mrmashWrapper forwards methodArgs under mr.mash's own names", { +test_that("MrmashOptions takes mr.mash's own argument names", { skip_if_not_installed("mr.mashr") ma <- MrmashOptions(max_iter = 10, tol = 0.5) expect_equal(ma$max_iter, 10) diff --git a/tests/testthat/test_relatednessQc.R b/tests/testthat/test_relatednessQc.R index f78614d0..2b0e83b4 100644 --- a/tests/testthat/test_relatednessQc.R +++ b/tests/testthat/test_relatednessQc.R @@ -101,6 +101,7 @@ test_that("maximizeCases preferentially retains cases", { # Related pairs above threshold: # C1-X1 (case-control), C2-X2 (case-control), C1-C2 (case-case), # X1-X3 (control-control) + # C3-X3 and X2-X3 sit below it, so they exclude nobody. rel <- data.frame( IID1 = c("C1", "C2", "C1", "X1", "C3", "X2"), IID2 = c("X1", "X2", "C2", "X3", "X3", "X3"), @@ -124,15 +125,49 @@ test_that("maximizeCases preferentially retains cases", { ) expect_type(result, "character") - # Controls related to kept cases should be excluded preferentially retained <- setdiff(pheno$IID, result) retained_cases <- intersect(retained, pheno$IID[pheno$pheno == 1]) retained_controls <- intersect(retained, pheno$IID[pheno$pheno == 0]) - # We expect at least 2 of 3 cases kept, and controls sacrificed - expect_true(length(retained_cases) >= 2) + # A case is lost only to another case: C1-C2 costs one (plinkQC drops + # a lone pair's IID1, C1), and C3 is related to no case. + expect_setequal(retained_cases, c("C2", "C3")) + # The controls are sacrificed instead: X2 for its kinship with the + # retained C2, then X1 of the remaining related pair X1 / X3. + expect_setequal(result, c("C1", "X2", "X1")) + expect_equal(retained_controls, "X3") expect_true(noRelatedPairsRemain(rel, result, threshold)) }) +test_that("maximizeCases ignores a case-control pair below the threshold", { + skip_if_not_installed("igraph") + skip_if_not_installed("plinkQC") + # Kinship 0.05 is not related at 0.125: nobody is excluded, as under + # maximizeUnrelated. + rel <- data.frame( + IID1 = "C1", + IID2 = "X1", + PI_HAT = 0.05, + stringsAsFactors = FALSE + ) + pheno <- data.frame( + IID = c("C1", "X1"), + pheno = c(1, 0), + stringsAsFactors = FALSE + ) + for (type in c("maximizeCases", "maximizeUnrelated")) { + expect_length( + filterRelatedness( + relatedness = rel, + relatednessThreshold = 0.125, + analysisType = type, + phenoData = pheno, + phenoCol = "pheno" + ), + 0L + ) + } +}) + test_that("maximizeCases errors without phenoData", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") diff --git a/tests/testthat/test_resultReaders.R b/tests/testthat/test_resultReaders.R index d6dca5a6..1177ca4c 100644 --- a/tests/testthat/test_resultReaders.R +++ b/tests/testthat/test_resultReaders.R @@ -75,12 +75,42 @@ path } +# The bundled fine-mapping example, published once as a VCF and read back +# once. Reading a published VCF is the slow step of a round trip, so the tests +# that need only "the example after a VCF round trip" share this copy instead +# of each writing and reading the same file again. +# @noRd +.rdr_fmVcf <- .rdr_tmp("shared_fm.vcf") +if (requireNamespace("VariantAnnotation", quietly = TRUE)) { + data(qtlFineMappingExample, envir = environment()) + writeGwasVcf(qtlFineMappingExample, .rdr_fmVcf, context = "context_1") + .rdr_fmVcfBack <- readFineMappingResult( + .rdr_fmVcf, + weightStandardized = TRUE + ) +} + +# One three-variant fit per context: small enough to publish and read back in +# a fraction of the example's time, for the tests that edit a published VCF's +# header or need only some VCF to read. +# @noRd +.rdr_smallFmr <- function(contexts = "c1") { + n <- length(contexts) + QtlFineMappingResult( + studyName = rep("s1", n), + context = contexts, + trait = rep("t1", n), + method = rep("susie", n), + entry = rep(list(.sc_makeFineMappingRow(3)), n) + ) +} + # ---- round trips ---------------------------------------------------------- test_that("a fine-mapping result round-trips through a published BED", { data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp("rt_fm.bed") - exportToBed(qtlFineMappingExample, path, columns = "all") + writeBed(qtlFineMappingExample, path, columns = "all") back <- readFineMappingResult(path, weightStandardized = TRUE) expect_s4_class(back, "QtlFineMappingResult") expect_equal(nrow(back), nrow(qtlFineMappingExample)) @@ -109,10 +139,9 @@ test_that("a fine-mapping result round-trips through a published BED", { }) test_that("a fine-mapping result round-trips through a published VCF", { + skip_if_not_installed("VariantAnnotation") data(qtlFineMappingExample, envir = environment()) - path <- .rdr_tmp("rt_fm.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") - back <- readFineMappingResult(path, weightStandardized = TRUE) + back <- .rdr_fmVcfBack expect_s4_class(back, "QtlFineMappingResult") expect_equal( .rdr_diff( @@ -126,16 +155,15 @@ test_that("a fine-mapping result round-trips through a published VCF", { }) test_that("the two formats agree with each other", { + skip_if_not_installed("VariantAnnotation") # The point of one shared vocabulary: whichever format a result was # published in, it reads back the same. A `region_start` that is 0-based # in the table and 1-based in the VCF header was caught by exactly this. data(qtlFineMappingExample, envir = environment()) bed <- .rdr_tmp("agree.bed") - vcf <- .rdr_tmp("agree.vcf") - exportToBed(qtlFineMappingExample, bed, columns = "all") - exportToVcf(qtlFineMappingExample, vcf, context = "context_1") + writeBed(qtlFineMappingExample, bed, columns = "all") fromBed <- readFineMappingResult(bed, weightStandardized = TRUE) - fromVcf <- readFineMappingResult(vcf, weightStandardized = TRUE) + fromVcf <- .rdr_fmVcfBack expect_equal(genomicRegion(fromBed), genomicRegion(fromVcf)) expect_equal( .rdr_diff( @@ -151,10 +179,9 @@ test_that("a published VCF restores the per-effect fit the header carried", { # `V` and `sets$cs_index` are per EFFECT, so no per-variant column can # hold them -- the `##SAMPLE` block is why they survive at all, and # colocalization's credible-set filter reads them off the fit. + skip_if_not_installed("VariantAnnotation") data(qtlFineMappingExample, envir = environment()) - path <- .rdr_tmp("fit.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") - fit <- susieFit(readFineMappingResult(path, weightStandardized = TRUE)) + fit <- susieFit(.rdr_fmVcfBack) original <- susieFit(qtlFineMappingExample) expect_equal(as.numeric(fit$V), as.numeric(original$V), tolerance = 1e-8) expect_equal( @@ -164,7 +191,7 @@ test_that("a published VCF restores the per-effect fit the header carried", { # A BED has no header to carry them, so there the fit is honestly absent # rather than half-invented. bed <- .rdr_tmp("fit.bed") - exportToBed(qtlFineMappingExample, bed) + writeBed(qtlFineMappingExample, bed) expect_null(susieFit(readFineMappingResult(bed, weightStandardized = TRUE))) }) @@ -172,7 +199,7 @@ test_that("TWAS weights round-trip through a published BED", { data(twasWeightsExample, envir = environment()) path <- .rdr_tmp("rt_w.bed") expect_message( - exportToBed(twasWeightsExample, path), + writeBed(twasWeightsExample, path), "fine-mapping-derived" ) back <- readTwasWeights(path) @@ -216,7 +243,7 @@ test_that("a merged table reads back as a multi-row collection", { qtlFineMappingLbfExample ) path <- .rdr_tmp("merged.bed") - exportToBed(combined, path) + writeBed(combined, path) back <- readFineMappingResult(path, weightStandardized = TRUE) expect_equal(nrow(back), nrow(combined)) md <- S4Vectors::mcols(back) @@ -402,7 +429,7 @@ test_that("a table with no way to identify its variants says so", { test_that("a weights file read as a fine-mapping result points back", { data(twasWeightsExample, envir = environment()) wt <- .rdr_tmp("x_wt.bed") - suppressMessages(exportToBed(twasWeightsExample, wt)) + suppressMessages(writeBed(twasWeightsExample, wt)) expect_error( readFineMappingResult(wt, weightStandardized = TRUE), "no `PIP` column.*readTwasWeights" @@ -414,7 +441,7 @@ test_that("a fine-mapping table reads as weights, because WGT is the weight", { # TWAS coefficient, which is why it publishes as WGT in both schemas. data(qtlFineMappingExample, envir = environment()) fm <- .rdr_tmp("x_fm.bed") - exportToBed(qtlFineMappingExample, fm) + writeBed(qtlFineMappingExample, fm) asWeights <- readTwasWeights(fm, weightStandardized = TRUE) expect_s4_class(asWeights, "TwasWeights") expect_equal( @@ -435,7 +462,7 @@ test_that("a fine-mapping table reads as weights, because WGT is the weight", { test_that("a published weight without its scale has to be told", { data(twasWeightsExample, envir = environment()) path <- .rdr_tmp("scale.bed") - suppressMessages(exportToBed(twasWeightsExample, path)) + suppressMessages(writeBed(twasWeightsExample, path)) # This fixture records the flag, so it reads without one. expect_s4_class(readTwasWeights(path), "TwasWeights") df <- utils::read.delim(path, check.names = FALSE) @@ -547,7 +574,7 @@ test_that("EZ round-trips as a SUPPLIED z and is not invented", { test_that("a result with no context or trait is a GWAS result", { data(gwasFineMappingExample, envir = environment()) path <- .rdr_tmp("gwas.bed") - exportToBed(gwasFineMappingExample, path) + writeBed(gwasFineMappingExample, path) back <- readFineMappingResult(path, weightStandardized = TRUE) expect_s4_class(back, "GwasFineMappingResult") expect_equal( @@ -571,7 +598,7 @@ test_that("the format follows the extension unless it is named", { test_that("a tabix-indexed table can be read by region", { data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp("region.bed.gz") - exportToBed(qtlFineMappingExample, path) + writeBed(qtlFineMappingExample, path) all <- readFineMappingResult(path, weightStandardized = TRUE) full <- topLoci(all, signalCutoff = 0) window <- GenomicRanges::GRanges( @@ -583,7 +610,7 @@ test_that("a tabix-indexed table can be read by region", { ) part <- readFineMappingResult( path, - region = window, + which = window, weightStandardized = TRUE ) expect_lt(length(variantIds(part)), length(variantIds(all))) @@ -605,9 +632,17 @@ test_that("an un-indexed file ignores a region loudly", { ) path <- .rdr_writeTable(df, "noindex.bed") expect_warning( - readFineMappingResult(path, region = "chr1:1-1000"), + readFineMappingResult( + path, + which = GenomicRanges::GRanges("chr1:1-1000") + ), "not bgzipped \\+ tabix-indexed" ) + # A region given in R is a GRanges; a string is refused, not read. + expect_error( + readFineMappingResult(path, which = "chr1:1-1000"), + "`which` must be a GRanges" + ) }) test_that("a missing file names itself", { @@ -637,10 +672,8 @@ test_that("a per-fit field with no ##SAMPLE key stops the writer", { }) test_that("the ##SAMPLE block survives a VariantAnnotation read", { - data(qtlFineMappingExample, envir = environment()) - path <- .rdr_tmp("sample_block.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") - meta <- pecotmr:::.prdVcfSampleMeta(VariantAnnotation::readVcf(path)) + skip_if_not_installed("VariantAnnotation") + meta <- pecotmr:::.prdVcfSampleMeta(VariantAnnotation::readVcf(.rdr_fmVcf)) # Named in the shared vocabulary, not the header's CamelCase: the reader # inverts the key table so everything downstream sees one set of names. expect_true(all(is_in( @@ -670,7 +703,7 @@ test_that("an empty result survives an export and a read", { data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp("empty_rt.bed") # A signal cutoff above 1 retains nothing, so the table is vacuous. - exportToBed(qtlFineMappingExample, path, signalCutoff = 2) + writeBed(qtlFineMappingExample, path, signalCutoff = 2) expect_equal(nrow(readFineMappingResult(path)), 0L) }) @@ -678,11 +711,9 @@ test_that("an empty result survives an export and a read", { # The VCF reader's edge paths # --------------------------------------------------------------------------- -# A published VCF, bgzipped and tabix-indexed so it can be read by region. +# A published VCF's bgzipped, tabix-indexed copy, so it can be read by region. # @noRd -.rdr_indexedVcf <- function(x, name, ...) { - plain <- .rdr_tmp(name) - exportToVcf(x, plain, ...) +.rdr_indexedVcf <- function(plain) { gz <- Rsamtools::bgzip(plain, dest = str_c(plain, ".gz"), overwrite = TRUE) Rsamtools::indexTabix(gz, format = "vcf") gz @@ -690,13 +721,9 @@ test_that("an empty result survives an export and a read", { test_that("a tabix-indexed VCF can be read by region", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingExample, envir = environment()) - gz <- .rdr_indexedVcf( - qtlFineMappingExample, - "region.vcf", - context = "context_1" - ) - all <- readFineMappingResult(gz, weightStandardized = TRUE) + gz <- .rdr_indexedVcf(.rdr_fmVcf) + # Read whole, the indexed copy holds what the shared round trip read. + all <- .rdr_fmVcfBack full <- topLoci(all, signalCutoff = 0) window <- GenomicRanges::GRanges( as.character(GenomicRanges::seqnames(full))[[1L]], @@ -707,7 +734,7 @@ test_that("a tabix-indexed VCF can be read by region", { ) part <- readFineMappingResult( gz, - region = window, + which = window, weightStandardized = TRUE ) expect_lt(length(variantIds(part)), length(variantIds(all))) @@ -719,15 +746,10 @@ test_that("a tabix-indexed VCF can be read by region", { test_that("a region naming no seqname in the VCF reads as empty", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingExample, envir = environment()) - gz <- .rdr_indexedVcf( - qtlFineMappingExample, - "noseq.vcf", - context = "context_1" - ) + gz <- .rdr_indexedVcf(.rdr_fmVcf) back <- readFineMappingResult( gz, - region = "chrZZ:1-1000", + which = GenomicRanges::GRanges("chrZZ:1-1000"), weightStandardized = TRUE, studyName = "s", context = "c", @@ -739,13 +761,12 @@ test_that("a region naming no seqname in the VCF reads as empty", { test_that("an un-indexed VCF ignores a region loudly", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp("plain.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") + writeGwasVcf(.rdr_smallFmr(), path) expect_warning( readFineMappingResult( path, - region = "chr22:1-1000000", + which = GenomicRanges::GRanges("chr1:1-1000"), weightStandardized = TRUE ), "not bgzipped \\+ tabix-indexed" @@ -762,11 +783,9 @@ test_that("a missing VCF names itself before VariantAnnotation is asked", { test_that("sampleSelect picks fits out of a multi-sample VCF", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingLbfExample, envir = environment()) # Two rows -> two samples in one file, which is GWAS-VCF's own shape. - expect_equal(nrow(qtlFineMappingLbfExample), 2L) path <- .rdr_tmp("multi.vcf") - exportToVcf(qtlFineMappingLbfExample, path) + writeGwasVcf(.rdr_smallFmr(c("c1", "c2")), path) both <- readFineMappingResult(path, weightStandardized = TRUE) expect_equal(nrow(both), 2L) samples <- VariantAnnotation::samples( @@ -786,9 +805,8 @@ test_that("sampleSelect picks fits out of a multi-sample VCF", { test_that("a VCF with no ##SAMPLE block falls back to the sample name", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp("nosample.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") + writeGwasVcf(.rdr_smallFmr(), path) stripped <- .rdr_tmp("nosample_stripped.vcf") lines <- readLines(path) writeLines(lines[!str_starts(lines, "##SAMPLE=")], stripped) @@ -860,6 +878,17 @@ test_that("a weights file read with no WGT column points at the other reader", { ) }) +test_that("a published window is read on UCSC sequence names", { + df <- data.frame( + region_id = "22_100_200", + region_start = 99L, + region_end = 200L + ) + gr <- .prdRowRegion(df, 1L, "x") + expect_identical(as.character(GenomicRanges::seqnames(gr)), "chr22") + expect_identical(GenomicRanges::start(gr), 100L) +}) + test_that("a region id with no underscores falls back to the variants' chrom", { expect_equal( .prdRegionChrom( @@ -895,9 +924,8 @@ test_that("a packed header value unpacks, and an absent one is NULL", { # there rather than requiring the full set. # @noRd .rdr_reheaderedVcf <- function(name, keys) { - data(qtlFineMappingExample, envir = environment()) path <- .rdr_tmp(str_c(name, "_src.vcf")) - exportToVcf(qtlFineMappingExample, path, context = "context_1") + writeGwasVcf(.rdr_smallFmr(), path) lines <- readLines(path) at <- which(str_starts(lines, "##SAMPLE=")) expect_length(at, 1L) @@ -956,10 +984,7 @@ test_that("a ##SAMPLE block with no RegionStart still reads", { test_that("a VCF with no samples reads as an empty result", { skip_if_not_installed("VariantAnnotation") - data(qtlFineMappingExample, envir = environment()) - path <- .rdr_tmp("sites_src.vcf") - exportToVcf(qtlFineMappingExample, path, context = "context_1") - lines <- readLines(path) + lines <- readLines(.rdr_fmVcf) keep <- !str_starts(lines, "##SAMPLE=") & !str_starts(lines, "##FORMAT=") # A sites-only VCF: the eight fixed columns and no sample at all, which # is a legal VCF and carries no results. @@ -974,3 +999,156 @@ test_that("a VCF with no samples reads as an empty result", { ) expect_error(readTwasWeights(out), "the VCF has no samples") }) + +test_that("each sample of a VCF reads back only its own variants", { + skip_if_not_installed("VariantAnnotation") + # Two fits over different variants: the records are their union, and a + # fit leaves the cells of the other's variants empty. + fmr <- GwasFineMappingResult( + studyName = c("g1", "g2"), + method = c("susie", "susie"), + entry = list( + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(2, offset = 1000L) + ) + ) + path <- .rdr_tmp("disjoint.vcf") + writeGwasVcf(fmr, path) + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_equal(unname(lengths(back)), c(3L, 2L)) + expect_false(anyNA(pip(back[1L]))) + expect_false(anyNA(pip(back[2L]))) +}) + +test_that("a BID naming a block the header does not list is refused", { + row <- data.frame(block_id = "b1|b2") + expect_identical( + pecotmr:::.prdBlockPositions(row, c("b2", NA, "b1")), + c(2L, NA, 1L) + ) + expect_null(pecotmr:::.prdBlockPositions(data.frame(block_id = "b1"), "b1")) + expect_error( + pecotmr:::.prdBlockPositions(row, "b3"), + "names block\\(s\\) b3 that the sample's header does not list" + ) +}) + +test_that("a header field one sample lacks reads back as NA for it", { + skip_if_not_installed("VariantAnnotation") + fmr <- GwasFineMappingResult( + studyName = c("g1", "g2"), + method = c("susie", "susie"), + entry = list( + .sc_makeFineMappingRow(3), + .sc_makeFineMappingRow(2, offset = 1000L) + ), + dataType = c("gwas", NA) + ) + path <- .rdr_tmp("onefield.vcf") + writeGwasVcf(fmr, path) + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_identical(back$dataType, c("gwas", NA)) +}) + +test_that(".prdBlockPiece reads one block's part of a header cell", { + expect_null(pecotmr:::.prdBlockPiece(NULL, 1L)) + expect_null(pecotmr:::.prdBlockPiece(".", 1L)) + expect_null(pecotmr:::.prdBlockPiece("a|b", NA_integer_)) + expect_identical(pecotmr:::.prdBlockPiece("a|b", 2L), "b") + # A single-block sample's cell is its one value whole. + expect_identical(pecotmr:::.prdBlockPiece("a", 2L), "a") +}) + +# ---- the genome build ------------------------------------------------------- + +test_that("a result read back carries the build its file recorded", { + x <- .rdr_smallFmr() + GenomeInfoDb::genome(x) <- "hg38" + bed <- .rdr_tmp("build_fm.bed") + writeBed(x, bed, columns = "all") + expect_equal( + unique(unname(GenomeInfoDb::genome( + readFineMappingResult(bed, weightStandardized = TRUE) + ))), + "hg38" + ) + skip_if_not_installed("VariantAnnotation") + vcf <- .rdr_tmp("build_fm.vcf") + writeGwasVcf(x, vcf) + expect_equal( + unique(unname(GenomeInfoDb::genome( + readFineMappingResult(vcf, weightStandardized = TRUE) + ))), + "hg38" + ) +}) + +test_that("a file that names no build reads back with none", { + data(qtlFineMappingExample, envir = environment()) + x <- qtlFineMappingExample + GenomeInfoDb::genome(x) <- NA_character_ + bed <- .rdr_tmp("nobuild_fm.bed") + writeBed(x, bed, columns = "all") + expect_true(all(is.na(GenomeInfoDb::genome( + readFineMappingResult(bed, weightStandardized = TRUE) + )))) + expect_true(is.na(pecotmr:::.prdBedBuild(bed))) +}) + +test_that("TWAS weights read back with the build their file recorded", { + data(twasWeightsExample, envir = environment()) + x <- twasWeightsExample + GenomeInfoDb::genome(x) <- "hg19" + bed <- .rdr_tmp("build_tw.bed") + writeBed(x, bed) + expect_equal( + unique(unname(GenomeInfoDb::genome(readTwasWeights(bed)))), + "hg19" + ) +}) + +test_that("a file of no lines, or of meta lines alone, still reads a build", { + # Every line a `##` line is the count's other branch: there is no first + # non-meta line to stop at. + empty <- .rdr_tmp("empty_build.bed") + writeLines(character(0), empty) + expect_true(is.na(pecotmr:::.prdBedBuild(empty))) + metaOnly <- .rdr_tmp("meta_only_build.bed") + writeLines(c("##genome=hg38", "##source=pecotmr"), metaOnly) + expect_equal(pecotmr:::.prdBedBuild(metaOnly), "hg38") + expect_equal(pecotmr:::.prdLeadingCount(c(TRUE, FALSE, TRUE)), 1L) +}) + +# =========================================================================== +# readFineMappingResult: a joined sample splits back into its blocks +# =========================================================================== + +test_that("readFineMappingResult splits a joined sample back into its blocks", { + skip_if_not_installed("VariantAnnotation") + x <- .rw_blockedGwasFmr() + out <- tempfile(fileext = ".vcf") + writeGwasVcf(x, out) + back <- readFineMappingResult(out, weightStandardized = TRUE) + expect_s4_class(back, "GwasFineMappingResult") + expect_identical(back$blockId, x$blockId) + expect_equal(unname(lengths(back)), c(3L, 3L)) + expect_equal(susieFit(back[2L])$V, c(0.3, 0.4)) + expect_identical(susieFit(back[2L])$sets$cs_index, 2L) + expect_equal(pip(back[2L]), pip(x[2L])) + expect_identical( + as.character(genomicRegion(back)), + as.character(genomicRegion(x)) + ) + expect_identical(back$regionGiven, c(TRUE, TRUE)) + # A block whose range is its variants' span reads back as computed. + mixed <- .rw_mixedGwasFmr() + out2 <- tempfile(fileext = ".vcf") + writeGwasVcf(mixed, out2) + expect_match( + .rw_sampleLines(out2), + "RegionGiven=TRUE|FALSE", + fixed = TRUE + ) + back2 <- readFineMappingResult(out2, weightStandardized = TRUE) + expect_identical(back2$regionGiven, c(TRUE, FALSE)) +}) diff --git a/tests/testthat/test_resultWriters.R b/tests/testthat/test_resultWriters.R index ed18d2da..72d0875e 100644 --- a/tests/testthat/test_resultWriters.R +++ b/tests/testthat/test_resultWriters.R @@ -1,5 +1,5 @@ -# Tests for the published result writers (resultWriters.R): exportToVcf, the -# GWAS-VCF-style writer, and exportToBed, the published long-format tables. +# Tests for the published result writers (resultWriters.R): writeGwasVcf, the +# GWAS-VCF-style writer, and writeBed, the published long-format tables. # ============================================================================= # Test data helpers @@ -64,7 +64,7 @@ makeTestFineMappingResult <- function(n = 5) { method = rep("susie", n), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl @@ -76,68 +76,18 @@ makeTestFineMappingResult <- function(n = 5) { ) } -# ============================================================================= -# GwasSumStats to VCF -# ============================================================================= - -test_that("exportToVcf writes GwasSumStats to uncompressed VCF", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - - ss <- makeTestGwasSumStats(5) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - - result <- exportToVcf(ss, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -# ============================================================================= -# GwasSumStats to bgzipped VCF -# ============================================================================= - -test_that("exportToVcf writes GwasSumStats to bgzipped VCF", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - - ss <- makeTestGwasSumStats(5) - out <- tempfile(fileext = ".vcf.bgz") - on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) - - result <- exportToVcf(ss, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - # ============================================================================= # Fine-mapping result to VCF # ============================================================================= -test_that("exportToVcf writes a fine-mapping result to uncompressed VCF", { +test_that("writeGwasVcf(FineMapping): emits PIP + CS FORMAT fields", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - - result <- exportToVcf(fm, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -test_that("exportToVcf(FineMapping): emits PIP + CS FORMAT fields", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - - fm <- makeTestFineMappingResult(5) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - exportToVcf(fm, out) + expect_equal(writeGwasVcf(fm, out), out) ln <- readLines(out) # The posterior fields the legacy create_vcf carried must be present. The CS # field is DYNAMIC (CS) -- the fixture carries cs_95 -> CS95. @@ -156,7 +106,7 @@ test_that("exportToVcf(FineMapping): emits PIP + CS FORMAT fields", { # Fine-mapping result to BCF # ============================================================================= -test_that("exportToVcf writes a fine-mapping result to BCF", { +test_that("writeGwasVcf writes a fine-mapping result to BCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") skip_if_not_installed("Rsamtools") @@ -205,7 +155,7 @@ test_that("exportToVcf writes a fine-mapping result to BCF", { out <- tempfile(fileext = ".bcf") on.exit(unlink(out), add = TRUE) - result <- exportToVcf(fm, out) + result <- writeGwasVcf(fm, out) expect_equal(result, out) expect_true(file.exists(out)) expect_gt(file.info(out)$size, 0) @@ -215,7 +165,7 @@ test_that("exportToVcf writes a fine-mapping result to BCF", { # Empty fine-mapping result errors # ============================================================================= -test_that("exportToVcf errors on an empty fine-mapping result", { +test_that("writeGwasVcf errors on an empty fine-mapping result", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -236,7 +186,7 @@ test_that("exportToVcf errors on an empty fine-mapping result", { posterior_sd = numeric(0), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = character(0), susieFit = list(), topLoci = empty_tl @@ -250,7 +200,7 @@ test_that("exportToVcf errors on an empty fine-mapping result", { out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - expect_error(exportToVcf(fm_empty, out), "no variants to write") + expect_error(writeGwasVcf(fm_empty, out), "no variants to write") }) # ============================================================================= @@ -280,7 +230,7 @@ test_that("exportToVcf errors on an empty fine-mapping result", { cs_95 = paste0("susie_", c(1L, 1L, 0L)), stringsAsFactors = FALSE ) - fineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) + FineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) }) QtlFineMappingResult( studyName = rep("study1", 2), @@ -291,73 +241,47 @@ test_that("exportToVcf errors on an empty fine-mapping result", { ) } -test_that("exportToVcf(FineMapping): splitByContext emits one VCF each", { +test_that("writeGwasVcf(FineMapping): each split flag emits one VCF per tag", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() - baseOut <- tempfile(fileext = ".vcf") - on.exit( - unlink(list.files( - dirname(baseOut), - pattern = basename(tools::file_path_sans_ext(baseOut)), - full.names = TRUE - )), - add = TRUE + # Each path is decorated with the tags its flags select; both flags + # combine them, context first. + cases <- list( + context = list( + flags = list(splitByContext = TRUE), + tags = c("brain", "blood") + ), + trait = list( + flags = list(splitByTrait = TRUE), + tags = c("ENSG_A", "ENSG_B") + ), + both = list( + flags = list(splitByContext = TRUE, splitByTrait = TRUE), + tags = c("brain.ENSG_A", "blood.ENSG_B") + ) ) - paths <- exportToVcf(fmr, baseOut, splitByContext = TRUE) - expect_length(paths, 2L) - # Each path is decorated with the context tag. - expect_true(any(grepl("\\.brain\\.vcf$", paths))) - expect_true(any(grepl("\\.blood\\.vcf$", paths))) - for (p in paths) { - expect_true(file.exists(p)) + d <- withr::local_tempdir() + for (case in names(cases)) { + paths <- exec( + writeGwasVcf, + fmr, + file.path(d, str_c(case, ".vcf")), + !!!cases[[case]]$flags + ) + expect_equal(length(paths), 2L, info = case) + expect_true( + setequal( + basename(paths), + str_c(case, ".", cases[[case]]$tags, ".vcf") + ), + info = case + ) + expect_true(all(file.exists(paths)), info = case) } }) -test_that("exportToVcf(FineMapping): splitByTrait emits one VCF each", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fmr <- .makeMultiTupleQtlFmr() - baseOut <- tempfile(fileext = ".vcf") - on.exit( - unlink(list.files( - dirname(baseOut), - pattern = basename(tools::file_path_sans_ext(baseOut)), - full.names = TRUE - )), - add = TRUE - ) - paths <- exportToVcf(fmr, baseOut, splitByTrait = TRUE) - expect_length(paths, 2L) - expect_true(any(grepl("\\.ENSG_A\\.vcf$", paths))) - expect_true(any(grepl("\\.ENSG_B\\.vcf$", paths))) -}) - -test_that("exportToVcf(FineMapping): both split flags combine the tags", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fmr <- .makeMultiTupleQtlFmr() - baseOut <- tempfile(fileext = ".vcf") - on.exit( - unlink(list.files( - dirname(baseOut), - pattern = basename(tools::file_path_sans_ext(baseOut)), - full.names = TRUE - )), - add = TRUE - ) - paths <- exportToVcf( - fmr, - baseOut, - splitByContext = TRUE, - splitByTrait = TRUE - ) - expect_length(paths, 2L) - expect_true(any(grepl("\\.brain\\.ENSG_A\\.vcf$", paths))) - expect_true(any(grepl("\\.blood\\.ENSG_B\\.vcf$", paths))) -}) - -test_that("exportToVcf(FineMapping): several fits make one multi-sample VCF", { +test_that("writeGwasVcf(FineMapping): several fits make one multi-sample VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() @@ -365,7 +289,7 @@ test_that("exportToVcf(FineMapping): several fits make one multi-sample VCF", { on.exit(unlink(out), add = TRUE) # No selector and no split flag: every matching fit is a SAMPLE of one # file, which is what GWAS-VCF's per-sample design means. - expect_identical(exportToVcf(fmr, out), out) + expect_identical(writeGwasVcf(fmr, out), out) lines <- readLines(out) header <- str_split(lines[str_starts(lines, "#CHROM")][[1L]], "\t")[[1L]] samples <- header[-seq_len(9L)] @@ -381,7 +305,7 @@ test_that("exportToVcf(FineMapping): several fits make one multi-sample VCF", { expect_length(body, 9L + 2L) }) -test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { +test_that("writeGwasVcf(FineMapping): a fit missing a variant leaves a gap", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # Two fits over DISJOINT variants: the records are the union, and each @@ -404,7 +328,7 @@ test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { context = ctx, trait = "g1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = ids, susieFit = list(), topLoci = tl @@ -414,7 +338,7 @@ test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { fmr <- combineFineMappingResults(mk(c(100, 200), "a"), mk(c(300), "b")) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - exportToVcf(fmr, out) + writeGwasVcf(fmr, out) lines <- readLines(out) cells <- str_split(keep(lines, str_starts, "chr1"), "\t") expect_identical(map_chr(cells, 2L), c("100", "200", "300")) @@ -429,8 +353,10 @@ test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { # GwasSumStats: multi-study selection, MAF/AF field, .gz rename # ============================================================================= -.makeTwoStudyGwasSumStats <- function(n = 3, withMaf = FALSE) { - mkGr <- function() { +# Two studies over the same variants, told apart by their sample size: N is +# 1000 in studyA and 2000 in studyB. +.makeTwoStudyGwasSumStats <- function(n = 3) { + mkGr <- function(nSample) { gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges( @@ -443,41 +369,45 @@ test_that("exportToVcf(FineMapping): a fit missing a variant leaves a gap", { A1 = rep("A", n), A2 = rep("T", n), Z = seq(1.5, by = -0.5, length.out = n), - N = rep(1000L, n) + N = rep(nSample, n) ) - if (withMaf) { - mc$MAF <- rep(0.2, n) - } S4Vectors::mcols(gr) <- mc gr } GwasSumStats( studyName = c("studyA", "studyB"), - entry = list(mkGr(), mkGr()), + entry = list(mkGr(1000L), mkGr(2000L)), genome = "hg38", ldReference = makeTestGenotypeHandle() ) } -test_that("exportToVcf(SumStats): multi-study needs a `study`", { +test_that("writeGwasVcf(SumStats): multi-study needs a `studyName`", { skip_if_not_installed("VariantAnnotation") ss2 <- .makeTwoStudyGwasSumStats() out <- tempfile(fileext = ".vcf") - expect_error(exportToVcf(ss2, out), "2 studies") + expect_error(writeGwasVcf(ss2, out), "2 studies") }) -test_that("exportToVcf(SumStats): `study` picks the chosen study", { +test_that("writeGwasVcf(SumStats): `studyName` picks the chosen study", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss2 <- .makeTwoStudyGwasSumStats() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - res <- exportToVcf(ss2, out, studyName = "studyB") + res <- writeGwasVcf(ss2, out, studyName = "studyB") expect_equal(res, out) - expect_true(file.exists(out)) + # The file holds studyB alone: one sample, named for it, with its N. A + # Number=A field reads back as a list matrix, one value per cell. + vcf <- VariantAnnotation::readVcf(out) + expect_identical(colnames(vcf), "studyB") + expect_identical( + list_c(VariantAnnotation::geno(vcf)$NS[, 1L]), + rep(2000L, 3L) + ) }) -test_that("exportToVcf(SumStats): emits AF when MAF is present", { +test_that("writeGwasVcf(SumStats): emits AF when MAF is present", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss <- GwasSumStats( @@ -502,7 +432,7 @@ test_that("exportToVcf(SumStats): emits AF when MAF is present", { ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - exportToVcf(ss, out) + writeGwasVcf(ss, out) expect_true(file.exists(out)) # The AF FORMAT field is declared in the header when MAF is present. # A source carrying only MAF gets the MAF key, not AF: the spec's AF is @@ -512,15 +442,16 @@ test_that("exportToVcf(SumStats): emits AF when MAF is present", { expect_false(any(grepl("ID=AF,", readLines(out)))) }) -test_that("exportToVcf(SumStats): .vcf.gz is renamed from .bgz", { +test_that("writeGwasVcf(SumStats): .vcf.gz is renamed from .bgz", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss <- makeTestGwasSumStats(5) out <- tempfile(fileext = ".vcf.gz") on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) - res <- exportToVcf(ss, out) + res <- writeGwasVcf(ss, out) expect_equal(res, out) - # writeVcf always emits .bgz; the writer renames it to the requested .gz. + # VariantAnnotation::writeVcf() always emits .bgz; the writer renames it + # to the requested .gz. expect_true(file.exists(out)) expect_false(file.exists(sub("\\.gz$", ".bgz", out))) }) @@ -530,13 +461,13 @@ test_that("exportToVcf(SumStats): .vcf.gz is renamed from .bgz", { # tags # ============================================================================= -test_that("exportToVcf(FineMapping): selectors pick a single row", { +test_that("writeGwasVcf(FineMapping): selectors pick a single row", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - res <- exportToVcf( + res <- writeGwasVcf( fmr, out, studyName = "study1", @@ -545,21 +476,28 @@ test_that("exportToVcf(FineMapping): selectors pick a single row", { method = "susie" ) expect_equal(res, out) - expect_true(file.exists(out)) + # One sample, the brain / ENSG_A fit, carrying that row's marginal + # effects; the blood row's are 0.01 larger. + vcf <- VariantAnnotation::readVcf(out) + expect_identical(colnames(vcf), "study1|brain|ENSG_A|susie") + expect_equal( + list_c(VariantAnnotation::geno(vcf)$ES[, 1L]), + c(0.31, 0.11, -0.19) + ) }) -test_that("exportToVcf(fine-mapping result): no matching rows errors", { +test_that("writeGwasVcf(fine-mapping result): no matching rows errors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() out <- tempfile(fileext = ".vcf") expect_error( - exportToVcf(fmr, out, studyName = "does_not_exist"), + writeGwasVcf(fmr, out, studyName = "does_not_exist"), "no rows match" ) }) -test_that("exportToVcf(FineMapping): split decorates a .vcf.bgz path", { +test_that("writeGwasVcf(FineMapping): split decorates a .vcf.bgz path", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .makeMultiTupleQtlFmr() @@ -576,7 +514,7 @@ test_that("exportToVcf(FineMapping): split decorates a .vcf.bgz path", { ), add = TRUE ) - paths <- exportToVcf(fmr, baseOut, splitByContext = TRUE) + paths <- writeGwasVcf(fmr, baseOut, splitByContext = TRUE) expect_length(paths, 2L) # The composite extension survives; the tag is injected before it. expect_true(all(grepl("\\.vcf\\.bgz$", paths))) @@ -584,7 +522,7 @@ test_that("exportToVcf(FineMapping): split decorates a .vcf.bgz path", { expect_true(any(grepl("\\.blood\\.vcf\\.bgz$", paths))) }) -test_that("exportToVcf(FineMapping): a context-less split keeps the path", { +test_that("writeGwasVcf(FineMapping): a context-less split keeps the path", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # GwasFineMappingResult has no context/trait axes, so the split tag set is @@ -592,13 +530,13 @@ test_that("exportToVcf(FineMapping): a context-less split keeps the path", { fm <- makeTestFineMappingResult(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - paths <- exportToVcf(fm, out, splitByContext = TRUE) + paths <- writeGwasVcf(fm, out, splitByContext = TRUE) expect_length(paths, 1L) expect_equal(paths[[1L]], out) expect_true(file.exists(out)) }) -test_that("exportToVcf(FineMapping): AF comes from topLoci `af`", { +test_that("writeGwasVcf(FineMapping): AF comes from topLoci `af`", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # The marginal view projects allele frequency to a column named `af`, so a @@ -622,7 +560,7 @@ test_that("exportToVcf(FineMapping): AF comes from topLoci `af`", { cs_95 = paste0("susie_", c(1L, 0L, 2L)), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl @@ -634,12 +572,12 @@ test_that("exportToVcf(FineMapping): AF comes from topLoci `af`", { ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - exportToVcf(fm, out) + writeGwasVcf(fm, out) expect_true(file.exists(out)) expect_true(any(grepl("ID=AF", readLines(out)))) }) -test_that("exportToVcf(FineMapping): LBF / LFSR / PUR / fullFit fields", { +test_that("writeGwasVcf(FineMapping): LBF / LFSR / PUR / fullFit fields", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # A rich topLoci exercises every posterior FORMAT field: per-variant @@ -670,7 +608,7 @@ test_that("exportToVcf(FineMapping): LBF / LFSR / PUR / fullFit fields", { cs_effect_susie_1 = c(0.4, NA, NA), stringsAsFactors = FALSE ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = tl$variant_id, susieFit = list(), topLoci = tl @@ -682,7 +620,7 @@ test_that("exportToVcf(FineMapping): LBF / LFSR / PUR / fullFit fields", { ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - exportToVcf(fm, out) + writeGwasVcf(fm, out) ln <- readLines(out) for (id in c( "ID=LBF", @@ -696,7 +634,7 @@ test_that("exportToVcf(FineMapping): LBF / LFSR / PUR / fullFit fields", { } }) -test_that("exportToVcf(FineMapping): falls back to marginal sumstats", { +test_that("writeGwasVcf(FineMapping): falls back to marginal sumstats", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fm <- makeTestFineMappingResult(5) @@ -708,7 +646,7 @@ test_that("exportToVcf(FineMapping): falls back to marginal sumstats", { ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - exportToVcf(fm, out) + writeGwasVcf(fm, out) expect_true(file.exists(out)) # marginal beta -> ES expect_true(any(grepl("ID=ES", readLines(out), fixed = TRUE))) @@ -723,11 +661,18 @@ test_that("plain and bgzipped VCF are written, the latter with an index", { skip_if_not_installed("VariantAnnotation") data(gwasSumStatsS4Example) d <- withr::local_tempdir() - exportToVcf(gwasSumStatsS4Example, outputPath = file.path(d, "a.vcf")) + # Each call returns the path it wrote. + expect_equal( + writeGwasVcf(gwasSumStatsS4Example, filename = file.path(d, "a.vcf")), + file.path(d, "a.vcf") + ) expect_true(file.exists(file.path(d, "a.vcf"))) - exportToVcf( - gwasSumStatsS4Example, - outputPath = file.path(d, "b.vcf.bgz") + expect_equal( + writeGwasVcf( + gwasSumStatsS4Example, + filename = file.path(d, "b.vcf.bgz") + ), + file.path(d, "b.vcf.bgz") ) expect_true(file.exists(file.path(d, "b.vcf.bgz"))) # index = TRUE, so the tabix index is written alongside. @@ -751,9 +696,9 @@ test_that("BCF output explains itself when Rsamtools cannot convert", { ) skip_if(canConvert, "Rsamtools::asBcf() works here; nothing to translate") expect_error( - exportToVcf( + writeGwasVcf( gwasSumStatsS4Example, - outputPath = file.path(d, "c.bcf") + filename = file.path(d, "c.bcf") ), "BCF output needs a working Rsamtools::asBcf" ) @@ -787,7 +732,7 @@ test_that(".vcfResolveBody uses posterior rows when no marginals exist", { expect_null(out$m) }) -test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { +test_that(".writeVcfImpl writes UCSC chromosome names", { skip_if_not_installed("VariantAnnotation") out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) @@ -799,7 +744,7 @@ test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { row.names = "Z" ) pecotmr:::.writeVcfImpl( - chrom = c("1", "1"), + chrom = c("1", "MT"), pos = c(100L, 200L), ref = c("A", "C"), alt = c("G", "T"), @@ -811,18 +756,18 @@ test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { ) body <- readLines(out) body <- body[!startsWith(body, "#")] - expect_true(all(startsWith(body, "chr1\t"))) + expect_setequal(stringr::str_extract(body, "^[^\t]+"), c("chr1", "chrM")) }) # ============================================================================= -# exportToBed: the fine-mapping schemas +# writeBed: the fine-mapping schemas # ============================================================================= -test_that("exportToBed writes the published top-loci schema", { +test_that("writeBed writes the published top-loci schema", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") expect_identical( - exportToBed(qtlFineMappingExample, out, signalCutoff = 0), + writeBed(qtlFineMappingExample, out, signalCutoff = 0), out ) tbl <- utils::read.delim(out, check.names = FALSE) @@ -854,10 +799,10 @@ test_that("exportToBed writes the published top-loci schema", { expect_false(is.unsorted(tbl$start[tbl[[1L]] == first])) }) -test_that("exportToBed bgzips and tabix-indexes a .gz fsusie table", { +test_that("writeBed bgzips and tabix-indexes a .gz fsusie table", { data(fsusieFineMappingExample) out <- withr::local_tempfile(fileext = ".bed.gz") - exportToBed(fsusieFineMappingExample, out, schema = "fsusie") + writeBed(fsusieFineMappingExample, out, schema = "fsusie") expect_true(file.exists(out)) expect_true(file.exists(str_c(out, ".tbi"))) hdr <- readLines(gzfile(out), n = 1L) @@ -888,12 +833,12 @@ test_that("exportToBed bgzips and tabix-indexes a .gz fsusie table", { )) }) -test_that("exportToBed emits the full schema for an empty result", { +test_that("writeBed emits the full schema for an empty result", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") # A cutoff no variant clears -> 0 data rows, but the schema must not # collapse. read.table() cannot read a header-only file, so read the line. - exportToBed(qtlFineMappingExample, out, signalCutoff = 2) + writeBed(qtlFineMappingExample, out, signalCutoff = 2) lines <- readLines(out) expect_length(lines, 1L) # A header-only file documents the whole vocabulary rather than @@ -903,13 +848,13 @@ test_that("exportToBed emits the full schema for an empty result", { expect_true(all(c("ES", "WGT", "PIP", "region_id") %in% hdr)) }) -test_that("exportToBed combines several results into one table", { +test_that("writeBed combines several results into one table", { data(qtlFineMappingExample) data(mvsusieFineMappingExample) one <- withr::local_tempfile(fileext = ".bed") both <- withr::local_tempfile(fileext = ".bed") - exportToBed(qtlFineMappingExample, one, signalCutoff = 0) - exportToBed( + writeBed(qtlFineMappingExample, one, signalCutoff = 0) + writeBed( list(qtlFineMappingExample, mvsusieFineMappingExample), both, signalCutoff = 0 @@ -928,17 +873,17 @@ test_that("exportToBed combines several results into one table", { ) }) -test_that("exportToBed rejects something that is not a result collection", { +test_that("writeBed 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") + expect_error(writeBed(data.frame(a = 1), out), "FineMappingResult") + expect_error(writeBed(list(), out), "at least one") }) test_that("the fsusie schema is still complete when no fsusie rows exist", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") # No fsusie rows at all -> a header-only table, not an error. - exportToBed(qtlFineMappingExample, out, schema = "fsusie") + writeBed(qtlFineMappingExample, out, schema = "fsusie") lines <- readLines(out) expect_length(lines, 1L) # a header-only file documents the schema, with no coverage discovered @@ -966,7 +911,7 @@ test_that("a merged multi-region fSuSiE table keeps each region's own window", { withRegion(b, wantB) ) out <- withr::local_tempfile(fileext = ".bed.gz") - exportToBed(both, out, schema = "fsusie") + writeBed(both, out, schema = "fsusie") tbl <- utils::read.delim(gzfile(out), check.names = FALSE) expect_setequal( unique(tbl$region_id), @@ -979,7 +924,7 @@ test_that("a merged multi-region fSuSiE table keeps each region's own window", { test_that("extraColumns appends trailing fields the object cannot know", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -991,7 +936,7 @@ test_that("extraColumns appends trailing fields the object cannot know", { # one value per row is equally valid perRow <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( qtlFineMappingExample, perRow, signalCutoff = 0, @@ -1007,7 +952,7 @@ test_that("extraColumns refuses a clash, a bad length, an unnamed list", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") expect_error( - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1016,7 +961,7 @@ test_that("extraColumns refuses a clash, a bad length, an unnamed list", { "would overwrite" ) expect_error( - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1025,7 +970,7 @@ test_that("extraColumns refuses a clash, a bad length, an unnamed list", { "one value per row" ) expect_error( - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1038,7 +983,7 @@ test_that("extraColumns refuses a clash, a bad length, an unnamed list", { test_that("extraColumns survive an empty table", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 2, @@ -1046,9 +991,12 @@ test_that("extraColumns survive an empty table", { ) lines <- readLines(out) expect_length(lines, 1L) + # The header-only schema, with the extra column after it. + plain <- withr::local_tempfile(fileext = ".bed") + writeBed(qtlFineMappingExample, plain, signalCutoff = 2) expect_identical( str_split(lines[[1L]], "\t")[[1L]], - c(str_split(readLines(out)[[1L]], "\t")[[1L]]) + c(str_split(readLines(plain)[[1L]], "\t")[[1L]], "source_file") ) }) @@ -1097,7 +1045,7 @@ test_that("genomicOrder uses `end` only to break ties, and only if numeric", { }) # ============================================================================= -# exportToBed: the TWAS-weight schemas +# writeBed: the TWAS-weight schemas # ============================================================================= makeTestTwasWeights <- function(weights, method = "lasso", nVariants = 3L) { @@ -1107,7 +1055,7 @@ makeTestTwasWeights <- function(weights, method = "lasso", nVariants = 3L) { context = "brain", trait = "g1", method = method, - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = ids, weights = weights, cvResult = list(metrics = c(rsq = 0.5, pval = 0.01)), @@ -1116,10 +1064,10 @@ makeTestTwasWeights <- function(weights, method = "lasso", nVariants = 3L) { ) } -test_that("exportToBed writes the published TWAS-weight schema", { +test_that("writeBed writes the published TWAS-weight schema", { data(twasWeightsExample) out <- withr::local_tempfile(fileext = ".bed") - expect_identical(exportToBed(twasWeightsExample, out), out) + expect_identical(writeBed(twasWeightsExample, out), out) tbl <- utils::read.delim(out, check.names = FALSE) expect_identical( names(tbl)[1:6], @@ -1147,11 +1095,11 @@ test_that("exportToBed writes the published TWAS-weight schema", { expect_identical(unique(tbl$region_end), 18850784L) }) -test_that("exportToBed writes one TWAS-weight row per matrix column", { +test_that("writeBed writes one TWAS-weight row per matrix column", { w <- matrix(c(0.1, 0.2, 0.3, -0.4, -0.5, -0.6), nrow = 3L) colnames(w) <- c("mark_a", "mark_b") out <- withr::local_tempfile(fileext = ".bed") - exportToBed(makeTestTwasWeights(w), out) + writeBed(makeTestTwasWeights(w), out) tbl <- utils::read.delim(out, check.names = FALSE) expect_identical(nrow(tbl), 6L) expect_setequal(unique(tbl$trait), c("mark_a", "mark_b")) @@ -1161,17 +1109,17 @@ test_that("exportToBed writes one TWAS-weight row per matrix column", { ) # a plain weight vector has no feature axis, so the column is empty plain <- withr::local_tempfile(fileext = ".bed") - exportToBed(makeTestTwasWeights(c(0.1, 0.2, 0.3)), plain) + writeBed(makeTestTwasWeights(c(0.1, 0.2, 0.3)), plain) plainTbl <- utils::read.delim(plain, check.names = FALSE) expect_identical(nrow(plainTbl), 3L) # a plain weight vector has no feature axis, so `trait` stays the row's expect_identical(unique(plainTbl$trait), "g1") }) -test_that("exportToBed bgzips and tabix-indexes a .gz TWAS-weight table", { +test_that("writeBed bgzips and tabix-indexes a .gz TWAS-weight table", { data(twasWeightsExample) out <- withr::local_tempfile(fileext = ".bed.gz") - exportToBed(twasWeightsExample, out) + writeBed(twasWeightsExample, out) expect_true(file.exists(out)) expect_true(file.exists(str_c(out, ".tbi"))) cols <- str_split(readLines(gzfile(out), n = 1L), "\t")[[1L]] @@ -1187,24 +1135,24 @@ test_that("exporting refuses a TwasWeights with no full-data fit", { context = "brain", trait = "g1", method = "susie", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = character(0), weights = NULL, cvResult = list(metrics = c(rsq = 0.5)) )) ) out <- withr::local_tempfile(fileext = ".bed") - expect_error(exportToBed(cvOnly, out), "no full-data fit") - expect_error(exportToBed(cvOnly, out), "fitFullData") + expect_error(writeBed(cvOnly, out), "no full-data fit") + expect_error(writeBed(cvOnly, out), "fitFullData") expect_error( - exportToVcf(cvOnly, withr::local_tempfile(fileext = ".vcf")), + writeGwasVcf(cvOnly, withr::local_tempfile(fileext = ".vcf")), "no full-data fit" ) # the offending row is named, so a genome-wide run says which one - expect_error(exportToBed(cvOnly, out), "s1\\|brain\\|g1\\|susie") + expect_error(writeBed(cvOnly, out), "s1\\|brain\\|g1\\|susie") # and a weightless-but-populated row is refused for the same reason expect_error( - exportToBed(makeTestTwasWeights(NULL), out), + writeBed(makeTestTwasWeights(NULL), out), "no full-data fit" ) }) @@ -1217,45 +1165,45 @@ test_that("exporting refuses a fine-mapping row with no fitted variants", { context = "c1", trait = "g1", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( variantIds = character(0), susieFit = list(), topLoci = data.frame() )) ) out <- withr::local_tempfile(fileext = ".bed") - expect_error(exportToBed(fmr, out), "no full-data fit") + expect_error(writeBed(fmr, out), "no full-data fit") }) -test_that("exportToBed combines a list of TwasWeights into one table", { +test_that("writeBed combines a list of TwasWeights into one table", { one <- withr::local_tempfile(fileext = ".bed") both <- withr::local_tempfile(fileext = ".bed") a <- makeTestTwasWeights(c(0.1, 0.2, 0.3), method = "lasso") b <- makeTestTwasWeights(c(0.4, 0.5, 0.6), method = "enet") - exportToBed(a, one) - exportToBed(list(a, b), both) + writeBed(a, one) + writeBed(list(a, b), both) expect_identical(length(readLines(both)), 2L * length(readLines(one)) - 1L) tbl <- utils::read.delim(both, check.names = FALSE) expect_setequal(unique(tbl$method), c("lasso", "enet")) }) -test_that("exportToBed rejects a list that holds neither result type", { +test_that("writeBed rejects a list that holds neither result type", { out <- withr::local_tempfile(fileext = ".bed") - expect_error(exportToBed(list(), out), "at least one") + expect_error(writeBed(list(), out), "at least one") expect_error( - exportToBed(list(1, 2), out), + writeBed(list(1, 2), out), "TwasWeights, QtlFineMappingResult or GwasFineMappingResult" ) }) # ============================================================================= -# exportToVcf: TWAS weights +# writeGwasVcf: TWAS weights # ============================================================================= -test_that("exportToVcf writes TWAS weights with one sample per model", { +test_that("writeGwasVcf writes TWAS weights with one sample per model", { data(twasWeightsExample) out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(twasWeightsExample, out) + writeGwasVcf(twasWeightsExample, out) lines <- readLines(out) header <- str_split( lines[str_starts(lines, "#CHROM")][[1L]], @@ -1274,23 +1222,27 @@ test_that("exportToVcf writes TWAS weights with one sample per model", { expect_length(body, 9L + 9L) }) -test_that("the TWAS-weight VCF describes each model in a ##SAMPLE line", { +test_that("the TWAS-weight VCF's ##SAMPLE lines describe each model, not CV", { data(twasWeightsExample) out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(twasWeightsExample, out) + writeGwasVcf(twasWeightsExample, out) sampleLines <- keep(readLines(out), str_starts, "##SAMPLE=") expect_length(sampleLines, 9L) + expect_true(all(str_detect(sampleLines, "TotalVariants="))) susie <- keep(sampleLines, str_detect, fixed("Method=lasso,"))[[1L]] expect_true(str_detect(susie, "Trait=ENSG00000130538")) expect_true(str_detect(susie, "TotalVariants=168")) expect_true(str_detect(susie, "WeightStandardized=FALSE")) expect_true(str_detect(susie, "DataType=bulk_rnaseq")) + # CV describes held-out folds; a published file has no data-secure way to + # say anything fold-level, so the header stops at identity + counts. + expect_false(any(str_detect(sampleLines, "rsq=|corr=|pval=|CvRegions="))) }) -test_that("exportToVcf narrows TWAS models with the identity selectors", { +test_that("writeGwasVcf narrows TWAS models with the identity selectors", { data(twasWeightsExample) out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(twasWeightsExample, out, method = "lasso") + writeGwasVcf(twasWeightsExample, out, method = "lasso") lines <- readLines(out) header <- str_split( lines[str_starts(lines, "#CHROM")][[1L]], @@ -1298,13 +1250,13 @@ test_that("exportToVcf narrows TWAS models with the identity selectors", { )[[1L]] expect_length(header[-seq_len(9L)], 1L) expect_error( - exportToVcf(twasWeightsExample, out, method = "nope"), + writeGwasVcf(twasWeightsExample, out, method = "nope"), "no rows match" ) # Selecting a fine-mapping method leaves nothing exportable, which is a # different refusal from "no rows match". expect_error( - suppressMessages(exportToVcf( + suppressMessages(writeGwasVcf( twasWeightsExample, out, method = "susie" @@ -1313,10 +1265,10 @@ test_that("exportToVcf narrows TWAS models with the identity selectors", { ) }) -test_that("exportToVcf names TWAS samples, or refuses a mismatched count", { +test_that("writeGwasVcf names TWAS samples, or refuses a mismatched count", { out <- withr::local_tempfile(fileext = ".vcf") tw <- makeTestTwasWeights(c(0.1, 0.2, 0.3)) - exportToVcf(tw, out, sampleName = "my_model") + writeGwasVcf(tw, out, sampleName = "my_model") lines <- readLines(out) header <- str_split( lines[str_starts(lines, "#CHROM")][[1L]], @@ -1324,7 +1276,7 @@ test_that("exportToVcf names TWAS samples, or refuses a mismatched count", { )[[1L]] expect_identical(header[[10L]], "my_model") expect_error( - exportToVcf(tw, out, sampleName = c("a", "b")), + writeGwasVcf(tw, out, sampleName = c("a", "b")), "one name per model" ) }) @@ -1336,13 +1288,13 @@ test_that("a TWAS-weight VCF unions the variants its models disagree on", { context = "brain", trait = "g1", method = "enet", - entry = list(twasWeightsRow( + entry = list(TwasWeightsRow( variantIds = c("chr1:300:A:G", "chr1:400:A:G"), weights = c(0.7, 0.8) )) ) out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(list(a, b), out) + writeGwasVcf(list(a, b), out) body <- keep(readLines(out), str_starts, "chr1") # union of {100,200,300} and {300,400} expect_length(body, 4L) @@ -1388,14 +1340,14 @@ test_that(".pubJoinMarginals gives an NA row where no marginal exists", { }) # ============================================================================= -# exportToBed: variant-level column completeness +# writeBed: variant-level column completeness # ============================================================================= test_that("the top-loci schema identifies the fit each row came from", { data(qtlFineMappingExample) data(mvsusieFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( list(qtlFineMappingExample, mvsusieFineMappingExample), out, signalCutoff = 0 @@ -1444,8 +1396,8 @@ test_that("columns = 'all' appends the rest of the source view", { data(qtlFineMappingExample) base <- withr::local_tempfile(fileext = ".bed") full <- withr::local_tempfile(fileext = ".bed") - exportToBed(qtlFineMappingExample, base, signalCutoff = 0) - exportToBed(qtlFineMappingExample, full, signalCutoff = 0, columns = "all") + writeBed(qtlFineMappingExample, base, signalCutoff = 0) + writeBed(qtlFineMappingExample, full, signalCutoff = 0, columns = "all") baseCols <- names(utils::read.delim(base, check.names = FALSE)) fullCols <- names(utils::read.delim(full, check.names = FALSE)) # additive: the published columns keep their place, the rest follow @@ -1464,7 +1416,7 @@ test_that("columns = 'all' appends the rest of the source view", { test_that("columns takes an explicit set, and refuses a bad one", { data(qtlFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1473,7 +1425,7 @@ test_that("columns takes an explicit set, and refuses a bad one", { cols <- names(utils::read.delim(out, check.names = FALSE)) expect_identical(cols[[length(cols)]], "grange_start") expect_error( - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1482,7 +1434,7 @@ test_that("columns takes an explicit set, and refuses a bad one", { "does not carry" ) expect_error( - exportToBed( + writeBed( qtlFineMappingExample, out, signalCutoff = 0, @@ -1492,11 +1444,13 @@ test_that("columns takes an explicit set, and refuses a bad one", { ) }) -test_that("the fsusie schema carries its study and takes columns = 'all'", { +test_that("the fsusie schema: both resolutions, its study, columns = 'all'", { data(fsusieFineMappingExample) out <- withr::local_tempfile(fileext = ".bed") - exportToBed(fsusieFineMappingExample, out, schema = "fsusie") + writeBed(fsusieFineMappingExample, out, schema = "fsusie") tbl <- utils::read.delim(out, check.names = FALSE) + # MAF is absent from this fixture, so the file carries the schema minus + # the columns that had nothing to say. expect_identical( names(tbl), setdiff( @@ -1507,10 +1461,13 @@ test_that("the fsusie schema carries its study and takes columns = 'all'", { "AF" ) ) + # Both resolutions by default. + expect_true(all(.FMB_FSUSIE_WAVELET_COLUMNS %in% names(tbl))) + expect_true(all(.FMB_FSUSIE_TRAIT_COLUMNS %in% names(tbl))) expect_false(anyNA(tbl$study)) full <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( fsusieFineMappingExample, full, schema = "fsusie", @@ -1523,7 +1480,7 @@ test_that("the fsusie schema carries its study and takes columns = 'all'", { expect_true(all(names(tbl) %in% fullCols)) # an explicitly named column is written even though it is empty here named <- withr::local_tempfile(fileext = ".bed") - exportToBed( + writeBed( fsusieFineMappingExample, named, schema = "fsusie", @@ -1537,35 +1494,14 @@ test_that("a TwasWeights element has no variant columns left to add", { data(twasWeightsExample) base <- withr::local_tempfile(fileext = ".bed") full <- withr::local_tempfile(fileext = ".bed") - exportToBed(twasWeightsExample, base) - exportToBed(twasWeightsExample, full, columns = "all") + writeBed(twasWeightsExample, base) + writeBed(twasWeightsExample, full, columns = "all") expect_identical( names(utils::read.delim(full, check.names = FALSE)), names(utils::read.delim(base, check.names = FALSE)) ) }) -test_that("the fsusie schema writes both resolutions by default", { - data(fsusieFineMappingExample) - out <- withr::local_tempfile(fileext = ".bed") - exportToBed(fsusieFineMappingExample, out, schema = "fsusie") - cols <- names(utils::read.delim(out, check.names = FALSE)) - # MAF is absent from this fixture, so the file carries the schema minus - # the columns that had nothing to say. - expect_identical( - cols, - setdiff( - .fmbFsusieColumns( - c("wavelet", "trait"), - c("CS95", "PUR95") - ), - "AF" - ) - ) - expect_true(all(.FMB_FSUSIE_WAVELET_COLUMNS %in% cols)) - expect_true(all(.FMB_FSUSIE_TRAIT_COLUMNS %in% cols)) -}) - test_that("fsusie `levels` drops one resolution, leaving a strict subset", { data(fsusieFineMappingExample) read <- function(lv) { @@ -1573,7 +1509,7 @@ test_that("fsusie `levels` drops one resolution, leaving a strict subset", { fileext = ".bed", .local_envir = parent.frame() ) - exportToBed( + writeBed( fsusieFineMappingExample, out, schema = "fsusie", @@ -1609,7 +1545,7 @@ test_that("fsusie `levels` drops one resolution, leaving a strict subset", { expect_identical(wav$grid_effects, both$grid_effects) expect_error( - exportToBed( + writeBed( fsusieFineMappingExample, withr::local_tempfile(), schema = "fsusie", @@ -1619,18 +1555,6 @@ test_that("fsusie `levels` drops one resolution, leaving a strict subset", { ) }) -test_that("the weight VCF header carries no cross-validation metrics", { - # CV describes held-out folds; a published file has no data-secure way to - # say anything fold-level, so the header stops at identity + counts. - data(twasWeightsExample) - out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(twasWeightsExample, out) - sampleLines <- keep(readLines(out), str_starts, "##SAMPLE=") - expect_length(sampleLines, 9L) - expect_true(all(str_detect(sampleLines, "TotalVariants="))) - expect_false(any(str_detect(sampleLines, "rsq=|corr=|pval=|CvRegions="))) -}) - # --------------------------------------------------------------------------- # EZ on the GwasSumStats path # @@ -1642,42 +1566,17 @@ test_that("the weight VCF header carries no cross-validation metrics", { # about where ES and SE came from. # --------------------------------------------------------------------------- -# @noRd -.ezss <- function(supplied) { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(c(100L, 200L), width = 1L) - ) - cols <- S4Vectors::DataFrame( - SNP = c("chr1:100:A:G", "chr1:200:C:T"), - A1 = c("G", "T"), - A2 = c("A", "C"), - Z = c(2.5, -1.2), - N = c(1000L, 1000L), - BETA = c(0.25, -0.12), - SE = c(0.1, 0.1) - ) - if (!is.null(supplied)) { - cols$z_supplied <- rep(supplied, 2L) - } - GwasSumStats( - studyName = "s", - entry = list(S4Vectors::`mcols<-`(gr, value = cols)), - genome = "hg38" - ) -} - # @noRd .ezFields <- function(x, name) { skip_if_not_installed("VariantAnnotation") out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(x, out) + writeGwasVcf(x, out) lines <- readLines(out) record <- keep(lines, str_starts, "chr1")[[1L]] str_split(str_split(record, "\t")[[1L]][[9L]], ":")[[1L]] } -test_that("exportToVcf(GwasSumStats) publishes EZ only for a supplied z", { +test_that("writeGwasVcf(GwasSumStats) publishes EZ only for a supplied z", { expect_true(is_in("EZ", .ezFields(.ezss(TRUE)))) expect_false(is_in("EZ", .ezFields(.ezss(FALSE)))) # A collection built by hand that never recorded the provenance is @@ -1689,50 +1588,17 @@ test_that("exportToVcf(GwasSumStats) publishes EZ only for a supplied z", { test_that("a supplied z survives the GwasSumStats VCF round trip", { skip_if_not_installed("VariantAnnotation") out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(.ezss(TRUE), out) + writeGwasVcf(.ezss(TRUE), out) back <- .readSumStatsVcf(out, NULL, NULL, NULL, "x") expect_equal(back$Z, c(2.5, -1.2)) expect_true(all(back$z_supplied)) # The derived case comes back derived, so a re-export does not promote it. - exportToVcf(.ezss(FALSE), out) + writeGwasVcf(.ezss(FALSE), out) derived <- .readSumStatsVcf(out, NULL, NULL, NULL, "x") expect_false(any(derived$z_supplied)) expect_equal(derived$Z, c(2.5, -1.2)) }) -# Drop the ES and SE subfields from one record (or leave a header line as-is). -# @noRd -.ezDropEsSe <- function(line) { - if (!str_starts(line, "chr1")) { - return(line) - } - fields <- str_split(line, "\t")[[1L]] - keys <- str_split(fields[[9L]], ":")[[1L]] - values <- str_split(fields[[10L]], ":")[[1L]] - keep <- !is_in(keys, c("ES", "SE")) - fields[[9L]] <- str_flatten(keys[keep], ":") - fields[[10L]] <- str_flatten(values[keep], ":") - str_flatten(fields, "\t") -} - -test_that("a z-only GWAS-VCF reads without ES and SE", { - # Reading EZ was missing altogether, so a file whose ES/SE were derived - # upstream from z either lost that fact or, with no ES/SE at all, was - # refused outright. - skip_if_not_installed("VariantAnnotation") - out <- withr::local_tempfile(fileext = ".vcf") - exportToVcf(.ezss(TRUE), out) - lines <- readLines(out) - lines <- lines[!str_detect(lines, "^##FORMAT= helper -> solver. +# through the helper hop. This is the same pattern as the BGLR probIn test in +# test_rrBglr.R, applied to every method. Together with the dispatch +# verification tests in test_rrDispatch.R, this covers the parameter-passing +# chain wrapper -> helper -> solver. # # Two patterns are used: # - For solvers whose results are consumed via direct field access (BGLR, @@ -15,7 +15,7 @@ context("regularized_regression - end-to-end solver verification") # ncvreg, L0Learn), faking the result is awkward, so the mock captures # the parameter and then raises a sentinel error that the test catches. -test_that("glmnetWeights forwards alpha to glmnet::cv.glmnet", { +test_that("lassoWeights / enetWeights forward alpha to glmnet::cv.glmnet", { skip_if_not_installed("glmnet") set.seed(42) X <- matrix(rnorm(50), nrow = 10) @@ -35,7 +35,7 @@ test_that("glmnetWeights forwards alpha to glmnet::cv.glmnet", { expect_equal(captured$alpha, 0.5) }) -test_that("ncvreg_weights forwards penalty to ncvreg::cv.ncvreg", { +test_that("scadWeights / mcpWeights forward penalty and nfolds to cv.ncvreg", { skip_if_not_installed("ncvreg") set.seed(42) X <- matrix(rnorm(50), nrow = 10) diff --git a/tests/testthat/test_rrGlmnet.R b/tests/testthat/test_rrGlmnet.R index 75650e1d..4b90324e 100644 --- a/tests/testthat/test_rrGlmnet.R +++ b/tests/testthat/test_rrGlmnet.R @@ -24,17 +24,6 @@ test_that("enetWeights computes elastic net weights", { expect_equal(nrow(result), p) }) -test_that("lassoWeights computes LASSO weights", { - 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) - result <- lassoWeights(X, y) - expect_equal(nrow(result), p) -}) - test_that("glmnetWeights handles zero-variance columns", { skip_if_not_installed("glmnet") set.seed(42) @@ -47,6 +36,7 @@ test_that("glmnetWeights handles zero-variance columns", { result <- glmnetWeights(X, y, alpha = 1), "glmnetWeights: dropping 1 zero-variance column" ) + expect_equal(nrow(result), p) expect_equal(result[3, 1], 0) }) @@ -83,13 +73,38 @@ test_that("glmnetWeights handles NA-producing columns gracefully", { expect_equal(result[4, 1], 0) }) -test_that("glmnetWeights with alpha = 0 (ridge regression) works", { +test_that("enetWeights takes its mixing, and ridgeWeights fixes it at 0", { skip_if_not_installed("glmnet") set.seed(42) - n <- 50 - p <- 10 + n <- 60 + p <- 8 X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) - result <- glmnetWeights(X, y, alpha = 0) - expect_equal(nrow(result), p) + # cv.glmnet draws its folds, so each pair is fitted from the same seed. + set.seed(11) + mixed <- enetWeights(X, y, alpha = 0.3) + set.seed(11) + expect_equal(mixed, glmnetWeights(X, y, 0.3)) + set.seed(11) + ridge <- ridgeWeights(X, y) + set.seed(11) + expect_equal(ridge, glmnetWeights(X, y, 0)) + expect_equal(nrow(ridge), p) + # A ridge keeps every variant. + expect_true(all(ridge != 0)) + expect_error(enetWeights(X, y, alpha = 2), "alpha.*<= 1") +}) + +test_that("glmnetWeights produces non-zero weights for correlated data", { + skip_if_not_installed("glmnet") + set.seed(42) + n <- 100 + p <- 10 + X <- matrix(rnorm(n * p), n, p) + beta_true <- c(3, -2, rep(0, p - 2)) + y <- X %*% beta_true + rnorm(n) + + w <- glmnetWeights(X, y, alpha = 0.5) + expect_length(w, p) + expect_true(any(w != 0)) }) diff --git a/tests/testthat/test_rrL0learn.R b/tests/testthat/test_rrL0learn.R index a48a83d6..f138b061 100644 --- a/tests/testthat/test_rrL0learn.R +++ b/tests/testthat/test_rrL0learn.R @@ -1,32 +1,6 @@ context("regularized_regression - l0learn") # ---- l0learnWeights ---- -test_that("l0learnWeights computes weights with default L0 penalty", { - skip_if_not_installed("L0Learn") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - result <- l0learnWeights(X, y) - expect_equal(nrow(result), p) - expect_equal(ncol(result), 1) - expect_true(all(is.finite(result))) -}) - -test_that("l0learnWeights computes weights with L0L2 penalty", { - skip_if_not_installed("L0Learn") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - result <- l0learnWeights(X, y, penalty = "L0L2") - expect_equal(nrow(result), p) - expect_equal(ncol(result), 1) - expect_true(all(is.finite(result))) -}) - test_that("l0learnWeights warns and zero-pads when X has zero-variance columns", { skip_if_not_installed("L0Learn") set.seed(42) @@ -50,7 +24,25 @@ test_that("l0learnWeights passes nGamma through to L0Learn.cvfit", { p <- 10 X <- matrix(rnorm(n * p), nrow = n) y <- X[, 1] * 0.5 + rnorm(n) - # nGamma = 0 is invalid; the underlying function should reject it, - # proving the argument reached L0Learn.cvfit. - expect_error(l0learnWeights(X, y, penalty = "L0L2", nGamma = 0)) + # nGamma is not a formal of l0learnWeights; it reaches the engine through + # methodArgs. + captured <- new.env(parent = emptyenv()) + local_mocked_bindings( + L0Learn.cvfit = function(...) { + captured$args <- list(...) + stop("STOP_AFTER_CAPTURE") + }, + .package = "L0Learn" + ) + expect_error( + l0learnWeights( + X, + y, + penalty = "L0L2", + methodArgs = L0learnOptions(nGamma = 3) + ), + "STOP_AFTER_CAPTURE" + ) + expect_equal(captured$args$nGamma, 3) + expect_equal(captured$args$penalty, "L0L2") }) diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index 9e2be53b..ce130481 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -39,6 +39,7 @@ test_that("lassosumRss runs successfully with valid input", { expect_true(all(is.finite(result$betaEst))) expect_equal(nrow(result$beta), p) expect_equal(ncol(result$beta), 20) + expect_length(result$conv, length(result$lambda)) }) test_that("lassosumRss with large lambda gives all-zero betas", { @@ -65,7 +66,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) expected <- seq_len(p) * 0.02 local_mocked_bindings( - .lassosumRssPath = function(bhat, ld, n, ...) { + .penalizedRssPath = function(bhat, ld, n, ...) { list( beta = cbind(rep(0, length(bhat)), expected), lambda = c(0.05, 0.01), @@ -97,7 +98,7 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { stat <- list(b = bhat, n = rep(n, p), variantNames = .rrwIds(p)) captured <- NULL local_mocked_bindings( - .lassosumRssPath = function(bhat, ld, n, ...) { + .penalizedRssPath = function(bhat, ld, n, ...) { captured <<- bhat list( beta = matrix(0, nrow = length(bhat), ncol = 2), diff --git a/tests/testthat/test_rrMrash.R b/tests/testthat/test_rrMrash.R index 14a59325..538b4cc8 100644 --- a/tests/testthat/test_rrMrash.R +++ b/tests/testthat/test_rrMrash.R @@ -1,21 +1,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)) - ) - result <- mrashWeights(X, y) - expect_true(is.numeric(result)) - expect_equal(length(result), p) -}) - test_that("mrashWeights subsets a user-supplied beta.init of length ncol(X) by keep", { skip_if_not_installed("glmnet") set.seed(42) diff --git a/tests/testthat/test_rrNcvreg.R b/tests/testthat/test_rrNcvreg.R index 292a7743..49131c49 100644 --- a/tests/testthat/test_rrNcvreg.R +++ b/tests/testthat/test_rrNcvreg.R @@ -30,19 +30,6 @@ test_that("ncvregWeights warns and zero-pads when X has zero-variance columns", expect_equal(result[5, 1], 0) }) -test_that("scadWeights computes weights and dispatches to ncvregWeights", { - skip_if_not_installed("ncvreg") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - result <- scadWeights(X, y) - expect_equal(nrow(result), p) - expect_equal(ncol(result), 1) - expect_true(all(is.finite(result))) -}) - test_that("mcpWeights computes weights and dispatches to ncvregWeights", { skip_if_not_installed("ncvreg") set.seed(42) @@ -55,22 +42,3 @@ test_that("mcpWeights computes weights and dispatches to ncvregWeights", { expect_equal(ncol(result), 1) expect_true(all(is.finite(result))) }) - -test_that("scadWeights passes nfolds through to cv.ncvreg", { - skip_if_not_installed("ncvreg") - set.seed(42) - n <- 50 - p <- 10 - X <- matrix(rnorm(n * p), nrow = n) - y <- X[, 1] * 0.5 + rnorm(n) - captured <- new.env(parent = emptyenv()) - local_mocked_bindings( - cv.ncvreg = function(X, y, penalty, nfolds = 5, ...) { - captured$nfolds <- nfolds - stop("STOP_AFTER_CAPTURE") - }, - .package = "ncvreg" - ) - expect_error(scadWeights(X, y, nfolds = 7), "STOP_AFTER_CAPTURE") - expect_equal(captured$nfolds, 7) -}) diff --git a/tests/testthat/test_rrPenalizedRss.R b/tests/testthat/test_rrPenalizedRss.R index 65dce373..45c1b343 100644 --- a/tests/testthat/test_rrPenalizedRss.R +++ b/tests/testthat/test_rrPenalizedRss.R @@ -28,34 +28,21 @@ test_that("penalizedRss errors on mismatched bhat and R dimensions", { ) }) -test_that("penalizedRss with large lambda gives all-zero betas (MCP)", { +test_that("penalizedRss with large lambda gives all-zero betas (MCP, SCAD)", { set.seed(42) p <- 10 n <- 100 bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss( - bhat = bhat, - R = diag(p), - n = n, - penalty = "MCP", - lambda = c(100) - ) - expect_true(all(result$betaEst == 0)) -}) - -test_that("penalizedRss with large lambda gives all-zero betas (SCAD)", { - set.seed(42) - p <- 10 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - result <- penalizedRss( - bhat = bhat, - R = diag(p), - n = n, - penalty = "SCAD", - lambda = c(100) - ) - expect_true(all(result$betaEst == 0)) + for (pen in c("MCP", "SCAD")) { + result <- penalizedRss( + bhat = bhat, + R = diag(p), + n = n, + penalty = pen, + lambda = c(100) + ) + expect_true(all(result$betaEst == 0), info = pen) + } }) test_that("penalizedRss with large lambda0 gives all-zero betas (L0)", { @@ -104,6 +91,7 @@ test_that("penalizedRss runs with SCAD and returns correct structure", { expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) + expect_equal(nrow(result$beta), p) }) test_that("penalizedRss runs with L0 and returns correct structure", { @@ -123,50 +111,12 @@ test_that("penalizedRss runs with L0 and returns correct structure", { expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) -}) - -test_that("penalizedRss LASSO matches lassosumRss on identity LD", { - set.seed(42) - p <- 10 - n <- 200 - bhat <- rnorm(p, sd = 0.2) - R <- diag(p) - lam <- exp(seq(log(0.001), log(0.1), length.out = 5)) - res_lasso <- penalizedRss( - bhat = bhat, - R = R, - n = n, - penalty = "lasso", - lambda = lam - ) - res_lassosum <- lassosumRss(bhat = bhat, R = R, n = n, lambda = lam) - expect_equal(res_lasso$beta, res_lassosum$beta, tolerance = 1e-4) + expect_equal(nrow(result$beta), p) }) # ---- Signal recovery on simulated summary statistics ---- -test_that("penalizedRss MCP recovers signal direction", { - set.seed(2024) - n <- 500 - p <- 20 - X <- matrix(rbinom(n * p, 2, 0.3), nrow = n) - beta_true <- rep(0, p) - beta_true[c(3, 10, 15)] <- c(0.4, -0.3, 0.2) - 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), 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) -}) - -test_that("penalizedRss SCAD recovers signal direction", { +test_that("mcpRssWeights / scadRssWeights recover the signal direction", { set.seed(2024) n <- 500 p <- 20 @@ -177,14 +127,17 @@ test_that("penalizedRss SCAD recovers signal direction", { bhat <- as.vector(cor(y, X)) R <- cor(X) 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) + fns <- list(MCP = mcpRssWeights, SCAD = scadRssWeights) + for (pen in names(fns)) { + w <- fns[[pen]]( + stat = stat, + ldReference = .rrwLdMatrix(R), + s = c(0.5, 0.9) + ) + expect_equal(length(w), p, info = pen) + expect_true(all(is.finite(w)), info = pen) + expect_gt(cor(w, beta_true), 0.4, label = str_c(pen, " correlation")) + } }) test_that("penalizedRss L0 recovers signal direction", { @@ -212,34 +165,22 @@ test_that("penalizedRss L0 recovers signal direction", { # ---- Weight wrapper structure ---- -test_that("scadRssWeights returns correct-length vector with attributes", { - set.seed(42) - p <- 10 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - 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") - expect_true(!is.null(sel)) - expect_equal(unname(sel["penalty"]), "SCAD") -}) - -test_that("mcpRssWeights returns correct-length vector with attributes", { +test_that("scadRssWeights / mcpRssWeights return p weights with attributes", { set.seed(42) p <- 10 n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) 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") - expect_true(!is.null(sel)) - expect_equal(unname(sel["penalty"]), "MCP") + fns <- list(SCAD = scadRssWeights, MCP = mcpRssWeights) + for (pen in names(fns)) { + w <- fns[[pen]](stat = stat, ldReference = .rrwLdMatrix(R), s = 0.5) + expect_equal(length(w), p, info = pen) + expect_true(is.numeric(w), info = pen) + sel <- attr(w, "penalized_rss_selection") + expect_true(!is.null(sel), info = pen) + expect_equal(unname(sel["penalty"]), pen, info = pen) + } }) test_that("l0learnRssWeights returns correct-length vector with attributes", { @@ -262,3 +203,328 @@ test_that("l0learnRssWeights returns correct-length vector with attributes", { expect_true(!is.null(sel)) expect_equal(unname(sel["penalty"]), "L0") }) + +# ---- Elastic-net mixing (alpha) ---------------------------------------------- + +# `v` centered and scaled to unit variance with the 1/n denominator. +.prs_scaleN <- function(v) { + v <- v - mean(v) + v / sqrt(mean(v^2)) +} + +# Genotypes and a phenotype standardized with the 1/n denominator, so that +# R = X'X / n is their LD and z = X'y / n the marginal effects: the RSS +# objective is then exactly twice glmnet's gaussian one. +.prs_standardized <- function(n = 200L, p = 15L, seed = 7L) { + set.seed(seed) + X <- matrix(rbinom(n * p, 2, 0.3), n, p) + beta <- replace(numeric(p), c(2, 4, 5), c(0.5, -0.4, 0.3)) + y <- as.numeric(X %*% beta) + rnorm(n) + Xs <- apply(X, 2, .prs_scaleN) + ys <- .prs_scaleN(y) + list( + X = Xs, + y = ys, + R = crossprod(Xs) / n, + z = as.numeric(crossprod(Xs, ys)) / n, + n = n + ) +} + +# MCP and SCAD at threshold `l` and concavity `g`, for |beta| = `ab`. +.prs_mcp <- function(ab, l, g) { + inner <- ab <= g * l + inner * (l * ab - ab^2 / (2 * g)) + (!inner) * (g * l^2 / 2) +} + +.prs_scad <- function(ab, l, g) { + lin <- ab <= l + mid <- !lin & ab <= g * l + flat <- !lin & !mid + lin * + l * + ab + + mid * (2 * g * l * ab - ab^2 - l^2) / (2 * (g - 1)) + + flat * l^2 * (g + 1) / 2 +} + +# The penalty penalizedRss() minimizes, written out: +# 2 P(beta; lambda * alpha) + lambda * (1 - alpha) * beta'beta. +.prs_penalty <- function(beta, lambda, alpha, penalty, gamma) { + l1 <- lambda * alpha + ab <- abs(beta) + p1 <- switch( + penalty, + lasso = l1 * ab, + MCP = .prs_mcp(ab, l1, gamma), + SCAD = .prs_scad(ab, l1, gamma) + ) + 2 * sum(p1) + lambda * (1 - alpha) * sum(beta^2) +} + +# The derivative of the L1-type part of the penalty at |beta| = `ab` > 0. +.prs_dpen <- function(ab, l1, penalty, gamma) { + switch( + penalty, + lasso = rep(l1, length(ab)), + MCP = pmax(l1 - ab / gamma, 0), + SCAD = (ab <= l1) * + l1 + + (ab > l1) * pmax(gamma * l1 - ab, 0) / (gamma - 1) + ) +} + +test_that("penalizedRss reproduces glmnet's elastic-net path on exact LD", { + skip_if_not_installed("glmnet") + d <- .prs_standardized() + lam <- c(0.1, 0.05, 0.02, 0.01) + for (a in c(1, 0.5, 0.2)) { + rss <- penalizedRss( + bhat = d$z * sqrt(d$n), + R = d$R, + n = d$n, + penalty = "lasso", + alpha = a, + lambda = lam, + thr = 1e-12, + maxiter = 1e5 + ) + gl <- glmnet::glmnet( + d$X, + d$y, + alpha = a, + lambda = lam, + standardize = FALSE, + intercept = FALSE, + thresh = 1e-14 + ) + expect_equal( + rss$beta, + unname(as.matrix(gl$beta)), + tolerance = 1e-6, + label = str_c("alpha = ", a) + ) + } +}) + +test_that("penalizedRss at alpha = 0 is ridge regression", { + d <- .prs_standardized() + p <- ncol(d$R) + rss <- penalizedRss( + bhat = d$z * sqrt(d$n), + R = d$R, + n = d$n, + penalty = "lasso", + alpha = 0, + lambda = c(1, 0.3), + thr = 1e-13, + maxiter = 1e5 + ) + expect_equal( + rss$beta[, 1], + as.numeric(solve(d$R + diag(p), d$z)), + tolerance = 1e-8 + ) + expect_equal( + rss$beta[, 2], + as.numeric(solve(d$R + 0.3 * diag(p), d$z)), + tolerance = 1e-8 + ) +}) + +test_that("fbeta is the objective the operators minimize, at any alpha", { + d <- .prs_standardized() + lam <- c(0.08, 0.03, 0.01) + for (pen in c("lasso", "MCP", "SCAD")) { + gamma <- if (pen == "SCAD") 3.7 else 3 + res <- penalizedRss( + bhat = d$z * sqrt(d$n), + R = d$R, + n = d$n, + penalty = pen, + alpha = 0.5, + lambda = lam, + gamma = gamma + ) + for (k in seq_along(lam)) { + b <- res$beta[, k] + objective <- sum(b * (d$R %*% b)) - + 2 * sum(b * d$z) + + .prs_penalty(b, lam[[k]], 0.5, pen, gamma) + expect_equal( + res$fbeta[[k]], + objective, + tolerance = 1e-10, + label = str_c(pen, " at lambda ", lam[[k]]) + ) + } + } +}) + +test_that("the updates are exact when the LD diagonal is not 1", { + # The curvature of one coordinate is v + l2. ncvreg writes it v (1 + l2), + # the same only at v = 1, so with a ridge term and a diagonal of 2 its + # fixed point is not the optimum. + d <- .prs_standardized() + R2 <- 2 * d$R + lam <- 0.03 + for (pen in c("lasso", "MCP", "SCAD")) { + gamma <- if (pen == "SCAD") 3.7 else 3 + b <- penalizedRss( + bhat = d$z * sqrt(d$n), + R = R2, + n = d$n, + penalty = pen, + alpha = 0.5, + lambda = lam, + gamma = gamma, + thr = 1e-13, + maxiter = 1e5 + )$beta[, 1] + l1 <- lam * 0.5 + # Half the gradient of the smooth part and the ridge term. + grad <- as.numeric(R2 %*% b) - d$z + lam * 0.5 * b + nz <- b != 0 + expect_gt(sum(nz), 0L) + stationary <- grad[nz] + + sign(b[nz]) * .prs_dpen(abs(b[nz]), l1, pen, gamma) + expect_lt(max(abs(stationary)), 1e-8, label = pen) + expect_true(all(abs(grad[!nz]) <= l1 + 1e-9), label = pen) + } +}) + +test_that("the default lambda path is scaled by the L1 share", { + d <- .prs_standardized(p = 6L) + bhat <- d$z * sqrt(d$n) + base <- exp(seq(log(1e-4), log(0.1), length.out = 20)) + expect_equal(penalizedRss(bhat, d$R, d$n)$lambda, base) + expect_equal(penalizedRss(bhat, d$R, d$n, alpha = 0.5)$lambda, base / 0.5) + expect_equal(penalizedRss(bhat, d$R, d$n, alpha = 0)$lambda, base / 1e-3) + # A path the caller gives is used as given. + expect_equal( + penalizedRss(bhat, d$R, d$n, alpha = 0.5, lambda = c(0.2, 0.1))$lambda, + c(0.2, 0.1) + ) +}) + +test_that("alpha is a share in [0, 1], above 0 for MCP and SCAD", { + d <- .prs_standardized(p = 5L) + bhat <- d$z * sqrt(d$n) + expect_error(penalizedRss(bhat, d$R, d$n, alpha = 1.5), "alpha.*<= 1") + expect_error(penalizedRss(bhat, d$R, d$n, alpha = -0.1), "alpha.*>= 0") + expect_error( + penalizedRss(bhat, d$R, d$n, penalty = "MCP", alpha = 0), + "above 0 for MCP" + ) + expect_error( + penalizedRss(bhat, d$R, d$n, penalty = "SCAD", alpha = 0), + "above 0 for SCAD" + ) + expect_error(penalizedRss(bhat, d$R, d$n, maxSwaps = -1), "maxSwaps") +}) + +test_that("lassosumRss is penalizedRss's lasso at alpha = 1, bit for bit", { + d <- .prs_standardized() + bhat <- d$z * sqrt(d$n) + lassosum <- lassosumRss(bhat, d$R, d$n) + lasso <- penalizedRss(bhat, d$R, d$n, penalty = "lasso") + expect_identical(lassosum$beta, lasso$beta) + expect_identical(lassosum$conv, lasso$conv) + expect_identical(lassosum$fbeta, lasso$fbeta) +}) + +# ---- enetRssWeights / ridgeRssWeights ---------------------------------------- + +# Twelve variants, two of them causal, as summary statistics with their LD. +.prs_weightsInput <- function() { + set.seed(42) + p <- 12 + n <- 300 + X <- matrix(rbinom(n * p, 2, 0.3), n, p) + y <- as.numeric(X[, c(2, 9)] %*% c(0.4, -0.3)) + rnorm(n) + list( + stat = list( + b = as.vector(cor(y, X)), + n = rep(n, p), + variantNames = .rrwIds(p) + ), + ld = .rrwLdMatrix(cor(X)) + ) +} + +test_that("enetRssWeights mixes at alpha and is lassosum at alpha = 1", { + f <- .prs_weightsInput() + w <- enetRssWeights(f$stat, f$ld) + expect_length(w, 12L) + sel <- attr(w, "penalized_rss_selection") + expect_equal(unname(sel[c("penalty", "alpha")]), c("lasso", "0.5")) + other <- enetRssWeights(f$stat, f$ld, alpha = 0.2) + expect_equal( + unname(attr(other, "penalized_rss_selection")["alpha"]), + "0.2" + ) + expect_equal( + as.numeric(enetRssWeights(f$stat, f$ld, alpha = 1)), + as.numeric(lassosumRssWeights(f$stat, f$ld)) + ) + expect_error(enetRssWeights(f$stat, f$ld, alpha = 2), "alpha.*<= 1") + # Its errors name it. + expect_error( + enetRssWeights(list(b = 1:3, n = rep(10, 3)), f$ld), + "enetRssWeights: `stat` must carry `variantNames`" + ) +}) + +test_that("ridgeRssWeights fits the alpha = 0 mixing over the ridge path", { + f <- .prs_weightsInput() + w <- ridgeRssWeights(f$stat, f$ld, fitRetention = "full") + expect_equal(unname(attr(w, "penalized_rss_selection")["alpha"]), "0") + # A ridge keeps every variant, along a path from 0.1 up. + expect_true(all(w != 0)) + fit <- attr(w, "fit") + expect_gte(min(fit$path$lambda), 0.1) + expect_equal(ncol(fit$beta), nrow(fit$path)) + expect_error( + ridgeRssWeights(list(b = 1:3, n = rep(10, 3)), f$ld), + "ridgeRssWeights: `stat` must carry `variantNames`" + ) +}) + +test_that("scadRssWeights and mcpRssWeights refuse alpha = 0 before fitting", { + f <- .prs_weightsInput() + cnd <- tryCatch(scadRssWeights(f$stat, f$ld, alpha = 0), error = identity) + expect_match(conditionMessage(cnd), "above 0 for SCAD") + # Raised up front, not from inside the shrinkage grid. + expect_null(cnd$parent) + expect_error(mcpRssWeights(f$stat, f$ld, alpha = 0), "above 0 for MCP") + expect_error(mcpRssWeights(f$stat, f$ld, alpha = 1.2), "alpha.*<= 1") +}) + +test_that("l0learnRssWeights takes its lambda path only as its own argument", { + f <- .prs_weightsInput() + expect_error( + l0learnRssWeights( + f$stat, + f$ld, + methodArgs = PenalizedRssOptions(lambda = 0.01) + ), + "lambda is supplied by pecotmr.*l0learnRssWeights' own `lambda`" + ) +}) + +test_that(".rssPenalty checks a penalty once and fills MCP / SCAD's gamma", { + pen <- pecotmr:::.rssPenalty + expect_equal(pen("SCAD")$gamma, 3.7) + expect_equal(pen("MCP")$gamma, 3) + expect_equal(pen("lasso")$gamma, 0) + expect_equal(pen("MCP", gamma = 5)$gamma, 5) + expect_equal(pen("lasso", alpha = 0)$alpha, 0) + expect_error(pen("SCAD", gamma = Inf), "gamma") + expect_error(pen("L0", lambda0 = -1), "lambda0") + expect_error(pen("L0L2", lambda2 = -1), "lambda2") + expect_error(pen("L0", maxSwaps = -1), "maxSwaps") + expect_error(pen("MCP", alpha = 0), "above 0 for MCP") + # l0learnRssWeights checks its lambda0 grid before any fit. + f <- .prs_weightsInput() + expect_error(l0learnRssWeights(f$stat, f$ld, lambda0 = -1), "lambda0") +}) diff --git a/tests/testthat/test_rrPrsCs.R b/tests/testthat/test_rrPrsCs.R index 8342a4d7..e6fcb255 100644 --- a/tests/testthat/test_rrPrsCs.R +++ b/tests/testthat/test_rrPrsCs.R @@ -29,7 +29,7 @@ test_that("prsCs errors on mismatched bhat and R dimensions", { ) }) -test_that("prsCs runs successfully with valid input", { +test_that("prsCs runs with valid input and estimates phi when none is given", { set.seed(42) p <- 10 n <- 100 @@ -52,24 +52,6 @@ test_that("prsCs runs successfully with valid input", { expect_true("betaEst" %in% names(result)) expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) -}) - -test_that("prsCs with phi = NULL estimates phi automatically", { - set.seed(42) - p <- 10 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - result <- prsCs( - bhat = bhat, - R = R, - n = n, - phi = NULL, - maf = rep(0.3, p), - nIter = 50, - nBurnin = 10, - thin = 2 - ) expect_true("phiEst" %in% names(result)) }) @@ -94,67 +76,33 @@ test_that("prsCs with explicit phi value", { expect_true("psiEst" %in% names(result)) }) -test_that("prsCs works without maf (maf = NULL)", { - set.seed(42) - p <- 10 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - result <- prsCs( - bhat = bhat, - R = R, - n = n, - maf = NULL, - nIter = 50, - nBurnin = 10, - thin = 2 - ) - expect_equal(length(result$betaEst), p) -}) - # ---- prsCs verbose output ---- -test_that("prsCs with verbose = TRUE produces output", { +test_that("prsCs verbose = TRUE reports its iterations and estimated phi", { set.seed(42) p <- 10 n <- 100 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - # n_iter >= 100 triggers the verbose print inside the MCMC loop - result <- prsCs( - bhat = bhat, - R = R, - n = n, - maf = rep(0.3, p), - nIter = 110, - nBurnin = 10, - thin = 2, - verbose = TRUE, - seed = 42L + # n_iter >= 100 triggers the verbose print inside the MCMC loop; phi is + # left NULL, so the sampler estimates it and prints the estimate. + out <- capture.output( + result <- prsCs( + bhat = bhat, + R = R, + n = n, + maf = rep(0.3, p), + nIter = 110, + nBurnin = 10, + thin = 2, + verbose = TRUE, + seed = 42L + ) ) + expect_match(out, "Iteration +100 of 110", all = FALSE) + expect_match(out, "Estimated global shrinkage parameter", all = FALSE) expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) -}) - -test_that("prsCs verbose with phi = NULL shows estimated phi", { - set.seed(42) - p <- 10 - n <- 100 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - result <- prsCs( - bhat = bhat, - R = R, - n = n, - phi = NULL, - maf = rep(0.3, p), - nIter = 110, - nBurnin = 10, - thin = 2, - verbose = TRUE, - seed = 42L - ) - expect_true("phiEst" %in% names(result)) expect_true(result$phiEst > 0) }) diff --git a/tests/testthat/test_rrSdpr.R b/tests/testthat/test_rrSdpr.R index 6b6ac884..3b55ca23 100644 --- a/tests/testthat/test_rrSdpr.R +++ b/tests/testthat/test_rrSdpr.R @@ -68,42 +68,30 @@ test_that("sdpr runs successfully", { expect_true(all(is.finite(result$betaEst))) }) -test_that("sdpr with per_variant_sample_size", { +test_that("sdpr runs with a per-variant sample size or an array vector", { set.seed(42) p <- 10 bhat <- rnorm(p, sd = 0.1) R <- diag(p) - result <- sdpr( - bhat = bhat, - R = R, - n = 100, - perVariantSampleSize = rep(100, p), - iter = 50, - burn = 10, - thin = 2, - verbose = FALSE + extras <- list( + perVariantSampleSize = list(perVariantSampleSize = rep(100, p)), + array = list(array = rep(1, p)) ) - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - -test_that("sdpr with valid array parameter", { - set.seed(42) - p <- 10 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - result <- sdpr( - bhat = bhat, - R = R, - n = 100, - array = rep(1, p), - iter = 50, - burn = 10, - thin = 2, - verbose = FALSE - ) - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) + for (nm in names(extras)) { + result <- exec( + sdpr, + bhat = bhat, + R = R, + n = 100, + !!!extras[[nm]], + iter = 50, + burn = 10, + thin = 2, + verbose = FALSE + ) + expect_equal(length(result$betaEst), p, info = nm) + expect_true(all(is.finite(result$betaEst)), info = nm) + } }) # ---- sdpr signal recovery ---- @@ -122,8 +110,8 @@ test_that("sdpr recovers signal direction on simulated genotype data", { bhat = bhat, R = R, n = n, - iter = 500, - burn = 200, + iter = 200, + burn = 50, thin = 5, verbose = FALSE, seed = 42L @@ -142,48 +130,26 @@ test_that("sdpr with verbose = TRUE produces output", { bhat <- rnorm(p, sd = 0.1) R <- diag(p) # iter >= 100 triggers the verbose print inside the MCMC loop - result <- sdpr( - bhat = bhat, - R = R, - n = 100, - iter = 110, - burn = 10, - thin = 2, - verbose = TRUE, - seed = 42L + out <- capture.output( + result <- sdpr( + bhat = bhat, + R = R, + n = 100, + iter = 110, + burn = 10, + thin = 2, + verbose = TRUE, + seed = 42L + ) ) + expect_match(out, "^100 iter\\. h2:", all = FALSE) expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) }) # ---- sdpr optLlk = 2 (multi-array) ---- -test_that("sdpr runs with optLlk = 2 and mixed array values", { - set.seed(42) - p <- 10 - bhat <- rnorm(p, sd = 0.1) - R <- diag(p) - # Mixed array: some variants from array 1, some from array 2 - arr <- c(rep(1, 5), rep(2, 5)) - result <- sdpr( - bhat = bhat, - R = R, - n = 100, - perVariantSampleSize = rep(100, p), - array = arr, - optLlk = 2, - iter = 50, - burn = 10, - thin = 2, - verbose = FALSE, - seed = 42L - ) - expect_type(result, "list") - expect_equal(length(result$betaEst), p) - expect_true(all(is.finite(result$betaEst))) -}) - -test_that("sdpr optLlk = 2 with realistic genotype data", { +test_that("sdpr runs with optLlk = 2 on mixed arrays and genotype LD", { set.seed(2024) n <- 500 p <- 20 @@ -209,6 +175,7 @@ test_that("sdpr optLlk = 2 with realistic genotype data", { verbose = FALSE, seed = 42L ) + expect_type(result, "list") expect_equal(length(result$betaEst), p) expect_true(all(is.finite(result$betaEst))) }) diff --git a/tests/testthat/test_rrSignalRecovery.R b/tests/testthat/test_rrSignalRecovery.R index fca5df91..7271ad5f 100644 --- a/tests/testthat/test_rrSignalRecovery.R +++ b/tests/testthat/test_rrSignalRecovery.R @@ -38,7 +38,7 @@ test_that("scadWeights recovers signal indices on simulated data", { skip_if_not_installed("ncvreg") sim <- .simulateSparseXY() w <- scadWeights(sim$X, sim$y, nfolds = 5) - expect_equal(length(w), ncol(sim$X)) + expect_equal(dim(w), c(ncol(sim$X), 1L)) expect_true(all(is.finite(w))) # SCAD is sparse: top-3 by absolute weight should heavily overlap truth. top3 <- order(abs(w), decreasing = TRUE)[1:3] @@ -49,7 +49,7 @@ test_that("l0learnWeights with default L0 penalty recovers signal indices", { skip_if_not_installed("L0Learn") sim <- .simulateSparseXY() w <- l0learnWeights(sim$X, sim$y, penalty = "L0", nFolds = 5) - expect_equal(length(w), ncol(sim$X)) + expect_equal(dim(w), c(ncol(sim$X), 1L)) expect_true(all(is.finite(w))) top3 <- order(abs(w), decreasing = TRUE)[1:3] expect_gte(length(intersect(top3, sim$signal_idx)), 2L) @@ -59,7 +59,7 @@ test_that("l0learnWeights with L0L2 penalty recovers signal direction", { skip_if_not_installed("L0Learn") sim <- .simulateSparseXY() w <- l0learnWeights(sim$X, sim$y, penalty = "L0L2", nFolds = 5) - expect_equal(length(w), ncol(sim$X)) + expect_equal(dim(w), c(ncol(sim$X), 1L)) expect_true(all(is.finite(w))) # L0L2 selects (gamma, lambda) over a 2D grid; correlation is the safer bet. expect_gt(cor(w, sim$beta_true), 0.4) @@ -69,6 +69,7 @@ test_that("dprWeights with VB fitting recovers signal direction", { skip_if_not_installed("RcppDPR") sim <- .simulateSparseXY() w <- dprWeights(sim$X, sim$y, fittingMethod = "VB") + expect_true(is.numeric(w)) expect_equal(length(w), ncol(sim$X)) expect_true(all(is.finite(w))) expect_gt(cor(w, sim$beta_true), 0.4) diff --git a/tests/testthat/test_rrSusie.R b/tests/testthat/test_rrSusie.R deleted file mode 100644 index 118877d3..00000000 --- a/tests/testthat/test_rrSusie.R +++ /dev/null @@ -1,156 +0,0 @@ -context("regularized_regression - susie") - -# ---- 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)) - result <- susieWeights(susieFit = mock_fit) - expect_equal(result, rep(0, 3)) -}) - -test_that("susieWeights errors on dimension mismatch", { - mock_fit <- list(pip = c(0.1, 0.2)) - X <- matrix(rnorm(30), nrow = 10, ncol = 3) - expect_error(susieWeights(X = X, susieFit = mock_fit), "Dimension mismatch") -}) - -test_that("susieWeights with alpha/mu/X_column_scale_factors calls coef.susie", { - p <- 5 - L <- 2 - mock_fit <- list( - alpha = matrix( - c( - 0.9, - 0.05, - 0.02, - 0.02, - 0.01, - 0.1, - 0.1, - 0.6, - 0.1, - 0.1 - ), - nrow = L, - ncol = p, - byrow = TRUE - ), - mu = matrix( - c( - 2.0, - 0.1, - 0.05, - 0.03, - 0.01, - 0.5, - 0.2, - 1.5, - 0.1, - 0.05 - ), - nrow = L, - ncol = p, - byrow = TRUE - ), - X_column_scale_factors = rep(1.0, p), - pip = runif(p), - intercept = 0 - ) - result <- susieWeights(susieFit = mock_fit) - expect_length(result, p) - expect_true(is.numeric(result)) - expect_true(any(result != 0)) -}) - -test_that("susieWeights calls susie when susie_fit is NULL", { - set.seed(42) - p <- 5 - n <- 50 - X <- matrix(rnorm(n * p), nrow = n) - y <- rnorm(n) - result <- susieWeights(susieFit = list(pip = rep(0.1, p))) - expect_equal(result, rep(0, p)) -}) - -# ---- susieAshWeights ---- -test_that("susieAshWeights returns zeros when no expected fields", { - mock_fit <- list(pip = c(0.1, 0.2, 0.3)) - result <- susieAshWeights(susieAshFit = mock_fit) - expect_equal(result, rep(0, 3)) -}) - -test_that("susieAshWeights errors on dimension mismatch", { - mock_fit <- list(pip = c(0.1, 0.2)) - X <- matrix(rnorm(30), nrow = 10, ncol = 3) - expect_error( - susieAshWeights(X = X, susieAshFit = mock_fit), - "Dimension mismatch" - ) -}) - -test_that("susieAshWeights with proper fields calls coef.susie", { - p <- 4 - L <- 2 - mock_fit <- list( - alpha = matrix(runif(L * p), nrow = L, ncol = p), - mu = matrix(rnorm(L * p), nrow = L, ncol = p), - theta = matrix(rnorm(L * p), nrow = L, ncol = p), - X_column_scale_factors = rep(1.0, p), - pip = runif(p), - intercept = 0 - ) - result <- susieAshWeights(susieAshFit = mock_fit) - expect_true(is.numeric(result)) - expect_true(length(result) >= p) -}) - -test_that("susieAshWeights calls susie when fit is NULL", { - set.seed(42) - p <- 4 - n <- 30 - X <- matrix(rnorm(n * p), nrow = n) - y <- rnorm(n) - result <- susieAshWeights(susieAshFit = list(pip = rep(0.1, p))) - expect_equal(result, rep(0, p)) -}) - -# ---- susieInfWeights ---- -test_that("susieInfWeights returns zeros when no expected fields", { - mock_fit <- list(pip = c(0.4, 0.5)) - result <- susieInfWeights(susieInfFit = mock_fit) - expect_equal(result, rep(0, 2)) -}) - -test_that("susieInfWeights errors on dimension mismatch", { - mock_fit <- list(pip = c(0.1, 0.2)) - X <- matrix(rnorm(30), nrow = 10, ncol = 3) - expect_error( - susieInfWeights(X = X, susieInfFit = mock_fit), - "Dimension mismatch" - ) -}) - -test_that("susieInfWeights with proper fields calls coef.susie", { - p <- 4 - L <- 2 - mock_fit <- list( - alpha = matrix(runif(L * p), nrow = L, ncol = p), - mu = matrix(rnorm(L * p), nrow = L, ncol = p), - theta = matrix(rnorm(L * p), nrow = L, ncol = p), - X_column_scale_factors = rep(1.0, p), - pip = runif(p), - intercept = 0 - ) - result <- susieInfWeights(susieInfFit = mock_fit) - expect_true(is.numeric(result)) - expect_true(length(result) >= p) -}) - -test_that("susieInfWeights calls susie when fit is NULL", { - set.seed(42) - p <- 4 - n <- 30 - X <- matrix(rnorm(n * p), nrow = n) - y <- rnorm(n) - result <- susieInfWeights(susieInfFit = list(pip = rep(0.1, p))) - expect_equal(result, rep(0, p)) -}) diff --git a/tests/testthat/test_sldscPostprocessingPipeline.R b/tests/testthat/test_sldscPostprocessingPipeline.R index d2f4f89a..15b6c150 100644 --- a/tests/testthat/test_sldscPostprocessingPipeline.R +++ b/tests/testthat/test_sldscPostprocessingPipeline.R @@ -2,7 +2,7 @@ # The pipeline is pure computation over an in-memory SldscData: no file I/O, # no mocks. Fixtures come from helper-sldsc.R (.sldscMkData / .sldscMkRun). -test_that("pipeline runs end-to-end on a single + joint SldscData", { +test_that("pipeline runs end-to-end, pooling every trait in the meta tables", { sd <- .sldscMkData() res <- suppressMessages(sldscPostprocessingPipeline(sd, mafCutoff = 0.05)) @@ -32,17 +32,12 @@ test_that("pipeline runs end-to-end on a single + joint SldscData", { expect_equal(res$params$trait_names, c("traitX", "traitY")) # baseline annotation detected from the joint run expect_true("baselineLD_0" %in% res$params$baseline_categories) -}) - -# The shape assertions above pass even when every meta row is NA, which is -# what a degenerate per-block tau (constant annotationJackknifeCoefs -> jackknife SE of 0) -# produces: metafor gets zero-variance inputs and DerSimonian-Laird drops -# every trait, leaving nTraits == 0. Assert on the values, not just the -# columns. -test_that("meta tables pool every trait rather than dropping them", { - sd <- .sldscMkData() - res <- suppressMessages(sldscPostprocessingPipeline(sd, mafCutoff = 0.05)) + # The shape assertions above pass even when every meta row is NA, which + # is what a degenerate per-block tau (constant annotationJackknifeCoefs + # -> jackknife SE of 0) produces: metafor gets zero-variance inputs and + # DerSimonian-Laird drops every trait, leaving nTraits == 0. Assert on + # the values, not just the columns. for (tbl in c("tauStar", "enrichment", "enrichstat")) { meta <- res$meta[[tbl]] expect_equal(meta$nTraits, rep(2L, nrow(meta)), info = tbl) @@ -146,9 +141,9 @@ test_that("pipeline falls back to positional rename when names don't match", { expect_equal(res$params$target_categories, c("L2_1", "L2_2")) }) -test_that("pipeline breaks the single loop when a trait has fewer runs than targets", { - # traitX has only ONE single run but there are TWO target categories: the - # i > length(singleRuns) break is hit on the 2nd target. +test_that("pipeline skips targets beyond a trait's single runs", { + # traitX has only ONE single run but there are TWO target categories, so + # only the first target is standardized in single mode. annot <- data.frame( CHR = c(1, 1, 2, 2), SNP = paste0("rs", 1:4), @@ -173,8 +168,8 @@ test_that("pipeline breaks the single loop when a trait has fewer runs than targ sd, targetCategories = c("annot_A_0", "annot_B_0") )) - # The break stops before annot_B_0's single run; the single-keyed summary - # therefore carries only annot_A_0. + # annot_B_0 has no single run; the single-keyed summary therefore + # carries only annot_A_0. sm <- res$per_trait$traitX$summary expect_equal(sm$target, "annot_A_0") expect_false(is.na(sm$tauStarSingle)) @@ -182,7 +177,7 @@ test_that("pipeline breaks the single loop when a trait has fewer runs than targ test_that("pipeline warns and skips a single run that fails to standardize", { # traitX's 2nd single run lacks the target category annot_B_0, so - # standardizeSldscTrait errors and the pipeline's tryCatch warns + skips it. + # standardizeSldscTrait errors and the pipeline warns and skips it. annot <- data.frame( CHR = c(1, 1, 2, 2), SNP = paste0("rs", 1:4), @@ -257,7 +252,7 @@ test_that("pipeline errors when targetCategories cannot be auto-detected", { test_that("pipeline warns and skips a joint run that fails to standardize", { af <- .sldscBranchAnnotFrq() # The joint run lacks the target category annot_A_0, so its standardization - # errors and the pipeline's joint-side tryCatch warns + skips it. + # errors and the pipeline warns and skips it. traits <- list( traitX = list( single = list(.sldscMkRun(c("annot_A_0", "baselineLD_0"))), @@ -302,7 +297,7 @@ test_that(".sldscCollectSingle returns empty parts for no standardizations", { test_that(".sldscTraitSingle tolerates a trait with no single-mode runs", { local_mocked_bindings( - sldscResults = function(...) NULL, + .sldscRun = function(...) NULL, .package = "pecotmr" ) ctx <- list(sldscData = NULL, targetCategories = c("t1", "t2")) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index 86fbc9b1..2bc03644 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -1,14 +1,122 @@ # Tests for R/sldscWrapper.R # -# File-based fixture builders (.makeAnnotGz / .make_frq / .makePolyfunSingle -# / .makePolyfunJoint / .makeSldscFixtures) and the in-memory SldscData -# builders (.sldscMkRun / .sldscMkData) live in helper-sldsc.R. +# The file-based fixture builders are below; the in-memory SldscData builders +# (.sldscMkRun / .sldscMkData), shared with the other S-LDSC tests, live in +# helper-sldsc.R. # # The reader functions (readSldscTrait/readSldscAnnot/readSldscFrq) do file I/O # and are tested against real fixture files. The compute functions # (computeSldscMRef/computeSldscAnnotSd/isBinarySldscAnnot/standardizeSldscTrait) # operate on an in-memory SldscData and are tested with in-memory fixtures. +# ============================================================================= +# File-based fixtures for the readers +# ============================================================================= +# +# Fixture convention: +# - 2 chromosomes (1, 2), 50 SNPs each -> 100 total +# - 2 target annotations: "annot_A" (binary), "annot_B" (continuous) +# - 10 jackknife blocks +# - Polyfun appends "_0" to target annotation names in .results + +# Create a single .annot.gz file for one chromosome. +# Real polyfun .annot.gz files have CHR, SNP, BP, CM + annotation columns only +# (no MAF/A1/A2 -- those come from the .frq / PLINK files). +.makeAnnotGz <- function(dir, chrom, nSnps = 50) { + df <- data.frame( + CHR = chrom, + SNP = paste0("rs", (chrom - 1L) * 100L + seq_len(nSnps)), + BP = seq_len(nSnps) * 1000L, + CM = seq_len(nSnps) * 0.01, + annot_A = sample(c(0L, 1L), nSnps, replace = TRUE), + annot_B = rnorm(nSnps, 2, 0.5), + stringsAsFactors = FALSE + ) + path <- file.path(dir, sprintf("target.%d.annot.gz", chrom)) + gz <- gzfile(path, "wb") + vroom::vroom_write(df, gz, delim = "\t") + close(gz) + invisible(df) +} + +# Create a PLINK .frq file for one chromosome +.make_frq <- function(dir, chrom, plinkName = "ref_chr", nSnps = 50) { + df <- data.frame( + CHR = chrom, + SNP = paste0("rs", (chrom - 1L) * 100L + seq_len(nSnps)), + A1 = "A", + A2 = "G", + MAF = runif(nSnps, 0.01, 0.49), + NCHROBS = 200L, + stringsAsFactors = FALSE + ) + path <- file.path(dir, sprintf("%s%d.frq", plinkName, chrom)) + vroom::vroom_write(df, path, delim = "\t") + invisible(df) +} + +# Create the three polyfun output files (.results, .log, .part_delete) +# for a single-target run. Real polyfun output includes baseline categories +# even in single-target mode, so we add 2 dummy baseline categories. +.makePolyfunSingle <- function( + dir, + prefix, + target_name, + nBlocks = 10, + h2g = 0.3, + tau = 1e-7, + enrichment = 2.5, + n_baseline = 2 +) { + target_cat <- paste0(target_name, "_0") + baseline_cats <- paste0("baselineLD_", seq_len(n_baseline) - 1L) + all_cats <- c(target_cat, baseline_cats) + n_cats <- length(all_cats) + + taus_all <- c(tau, rep(1e-8, n_baseline)) + enrichments_all <- c(enrichment, rep(1.0, n_baseline)) + + results <- data.frame( + Category = all_cats, + Coefficient = taus_all, + Coefficient_std_error = abs(taus_all) * 0.3, + Enrichment = enrichments_all, + Enrichment_std_error = enrichments_all * 0.2, + Enrichment_p = rep(0.01, n_cats), + `Prop._h2` = c(0.15, rep(0.425, n_baseline)), + `Prop._SNPs` = c(0.06, rep(0.47, n_baseline)), + check.names = FALSE, + stringsAsFactors = FALSE + ) + vroom::vroom_write(results, paste0(prefix, ".results"), delim = "\t") + + writeLines( + c( + "Analysis started at 2024-01-01", + sprintf("Total Observed scale h2: %g (0.05)", h2g), + "Analysis finished" + ), + paste0(prefix, ".log") + ) + + blocks <- matrix( + rnorm( + nBlocks * n_cats, + mean = rep(taus_all, each = nBlocks), + sd = abs(rep(taus_all, each = nBlocks)) * 0.5 + ), + nrow = nBlocks, + ncol = n_cats + ) + colnames(blocks) <- all_cats + vroom::vroom_write( + as.data.frame(blocks), + paste0(prefix, ".part_delete"), + delim = "\t" + ) + invisible(NULL) +} + # ============================================================================= # .sldscDetectAnnotCols # ============================================================================= @@ -262,12 +370,6 @@ test_that("computeSldscAnnotSd errors with zero degrees of freedom", { # computeSldscMRef (operates on SldscData) # ============================================================================= -test_that("computeSldscMRef counts MAF > cutoff SNPs from the frq table", { - M <- computeSldscMRef(.sldscMkData(), mafCutoff = 0.05) - expect_true(is.integer(M)) - expect_equal(M, 6L) # all 6 frq SNPs have MAF 0.2 > 0.05 -}) - test_that("computeSldscMRef counts all SNPs when mafCutoff = 0", { expect_equal(computeSldscMRef(.sldscMkData(), mafCutoff = 0), 6L) }) @@ -286,7 +388,9 @@ test_that("computeSldscMRef applies the MAF cutoff", { stringsAsFactors = FALSE ) sd <- SldscData(annot, frq, list()) - expect_equal(computeSldscMRef(sd, mafCutoff = 0.05), 2L) # rs1, rs3 + M <- computeSldscMRef(sd, mafCutoff = 0.05) + expect_true(is.integer(M)) + expect_equal(M, 2L) # rs1, rs3 }) test_that("computeSldscMRef falls back to annot row count when frq absent and mafCutoff = 0", { @@ -539,7 +643,7 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { # ============================================================================= -# metaSldscRandom (unchanged: operates on standardized per-trait estimates) +# metaSldscRandom (operates on standardized per-trait estimates) # ============================================================================= .makePerTraitMeta <- function( @@ -549,7 +653,9 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { ses = NULL ) { if (is.null(means)) { - means <- rnorm(nTraits, 1e-5, 1e-6) + # Seeded, so the fixture is the same on every run, and scoped, so + # the caller's random stream is left as it was. + means <- withr::with_seed(1L, rnorm(nTraits, 1e-5, 1e-6)) } if (is.null(ses)) { ses <- rep(1e-6, nTraits) @@ -572,30 +678,18 @@ test_that("standardizeSldscTrait errors on non-SldscData input", { per_trait } -test_that("metaSldscRandom works for tauStar", { +test_that("metaSldscRandom meta-analyzes tauStar, enrichment and enrichstat", { pt <- .makePerTraitMeta(nTraits = 4) - result <- metaSldscRandom(pt, "A_0", quantity = "tauStar") - expect_true(is.list(result)) - expect_equal(result$nTraits, 4L) - expect_true(is.numeric(result$mean)) - expect_true(is.numeric(result$se)) - expect_true(is.numeric(result$p)) - expect_true(result$se > 0) - expect_equal(length(result$traitsUsed), 4L) -}) - -test_that("metaSldscRandom works for enrichment", { - pt <- .makePerTraitMeta(nTraits = 3) - result <- metaSldscRandom(pt, "A_0", quantity = "enrichment") - expect_equal(result$nTraits, 3L) - expect_true(is.finite(result$mean)) -}) - -test_that("metaSldscRandom works for enrichstat", { - pt <- .makePerTraitMeta(nTraits = 3) - result <- metaSldscRandom(pt, "A_0", quantity = "enrichstat") - expect_equal(result$nTraits, 3L) - expect_true(is.finite(result$mean)) + for (quantity in c("tauStar", "enrichment", "enrichstat")) { + result <- metaSldscRandom(pt, "A_0", quantity = quantity) + expect_true(is.list(result), info = quantity) + expect_equal(result$nTraits, 4L, info = quantity) + expect_true(is.finite(result$mean), info = quantity) + expect_true(is.numeric(result$se), info = quantity) + expect_true(is.numeric(result$p), info = quantity) + expect_true(result$se > 0, info = quantity) + expect_equal(length(result$traitsUsed), 4L, info = quantity) + } }) # A per-trait $summary carrying the wide (Single/Joint) columns that @@ -682,13 +776,6 @@ test_that("metaSldscRandom skips traits with NA or zero SE", { expect_true(is.na(result$mean)) }) -test_that("metaSldscRandom skips NULL entries", { - pt <- .makePerTraitMeta(nTraits = 3) - pt$trait2 <- NULL - result <- metaSldscRandom(pt, "A_0", "tauStar") - expect_equal(result$nTraits, 2L) -}) - test_that("metaSldscRandom generates names for unnamed list", { pt <- .makePerTraitMeta(nTraits = 2) names(pt) <- NULL @@ -864,6 +951,10 @@ test_that(".sldscViewForMeta returns NULL when no matching columns", { }) +# ============================================================================= +# Annotation variance, positional annotCols, and meta-analysis arguments +# ============================================================================= + test_that("a constant annotation column contributes no variance", { # var() of a constant is 0 and of an all-NA column is NA; both must come # back as 0 so the column simply drops out of the weighted sum rather diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 58aabf6f..73865558 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -1,20 +1,41 @@ context("sumstats_qc") -# Previous tests against `rssBasicQc()` and the legacy -# `summaryStatsQc(rssInput, ldData)` signature have been removed because: -# * `rssBasicQc()` was folded into `summaryStatsQc()` -# * `summaryStatsQc()` now dispatches on `GwasSumStats` / `QtlSumStats` -# S4 collections (DFrame subclasses), not on a (rssInput list, ldData) -# pair -# * `QcResult` and the accessors `getRssInput()`, `getLdData()`, -# `getOutlierNumber()` have been removed; QC audit lives on -# `qcInfo()` -# Integration coverage of `summaryStatsQc()` lives in the -# pipeline test files (test_colocboostPipeline.R, etc.). -# -# What remains here: tests of internal QC helpers -# (`ldMismatchQc`, `krigingOutlierQc`) whose -# signatures and contracts are unchanged. +.gsd_makeHandle <- function(snp_n = 2L) { + new( + "GenotypeHandle", + path = "/tmp/sketch", + format = "plink2", + snpInfo = data.frame( + SNP = paste0("rs", seq_len(snp_n)), + CHR = rep("chr1", snp_n), + BP = seq(100L, by = 100L, length.out = snp_n), + A1 = rep("A", snp_n), + A2 = rep("G", snp_n), + stringsAsFactors = FALSE + ), + nSamples = 10L, + sampleIds = paste0("s", seq_len(10L)), + pgenPtr = NULL + ) +} + +.gsd_makeGwasSumStats <- function(mcolsDf, snp_n = nrow(mcolsDf)) { + 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(mcolsDf) + GwasSumStats( + studyName = "G1", + entry = list(gr), + genome = "hg19", + ldReference = .gsd_makeHandle(snp_n), + qcOptions = list(prebuilt = "synthetic") + ) +} # =========================================================================== # ldMismatchQc @@ -78,6 +99,52 @@ test_that(".entryToSumstatDf: a declared MAF is not overwritten by af", { expect_equal(df$af, 0.8) }) +test_that(".sumStatsDf flattens the tuple sumStats() selects", { + data(qtlSumStatsExample, package = "pecotmr", envir = environment()) + qss <- qtlSumStatsExample + st <- as.character(qss$study[[1L]]) + ctx <- as.character(qss$context[[1L]]) + tr <- as.character(qss$trait[[1L]]) + expect_identical( + .sumStatsDf(qss, studyName = st, context = ctx, trait = tr), + .entryToSumstatDf( + sumStats(qss, studyName = st, context = ctx, trait = tr) + ) + ) + expect_error( + .sumStatsDf( + qss, + studyName = st, + context = ctx, + trait = tr, + require = "NOPE" + ), + str_c("QtlSumStats[", st, "/", ctx, "/", tr, "]: entry has no NOPE"), + fixed = TRUE + ) +}) + +test_that(".sumStatsDf names a GWAS by study, an unset selector ", { + data( + gwasSumStatsS4Example, + qtlSumStatsExample, + package = "pecotmr", + envir = environment() + ) + gss <- gwasSumStatsS4Example + st <- as.character(gss$study[[1L]]) + expect_error( + .sumStatsDf(gss, studyName = st, require = "NOPE"), + str_c("GwasSumStats[", st, "]: entry has no NOPE"), + fixed = TRUE + ) + expect_error( + .sumStatsDf(qtlSumStatsExample, require = "NOPE"), + "QtlSumStats[//]: entry has no NOPE", + fixed = TRUE + ) +}) + test_that("ldMismatchQc dentist returns a data frame with an outlier column", { set.seed(42) p <- 20 @@ -104,15 +171,15 @@ test_that("ldMismatchQc slalom returns a data frame with an outlier column", { test_that("ldMismatchQc method argument is validated", { z <- rnorm(5) R <- diag(5) - expect_error(ldMismatchQc(z, R = R, method = "invalid")) + expect_error( + ldMismatchQc(z, R = R, method = "invalid"), + "`method`: unknown engine 'invalid'. Known: slalom, dentist.", + fixed = TRUE + ) }) # =========================================================================== -# ldMismatchQcMethod resolver -# =========================================================================== - -# =========================================================================== -# krigingOutlierQc +# raiss and its helpers # =========================================================================== context("raiss") @@ -181,16 +248,22 @@ test_that("Input validation for raiss works correctly", { input_data_zscores_unordered <- generateDummyData( known_zscores_ordered = FALSE ) - expect_error(raiss( - input_data_ref_panel_unordered$ref_panel, - input_data$known_zscores, - input_data$ldMatrix - )) - expect_error(raiss( - input_data$ref_panel, - input_data_zscores_unordered$known_zscores, - input_data$ldMatrix - )) + expect_error( + raiss( + input_data_ref_panel_unordered$ref_panel, + input_data$known_zscores, + input_data$ldMatrix + ), + "refPanel and knownZscores must be in increasing order of pos" + ) + expect_error( + raiss( + input_data$ref_panel, + input_data_zscores_unordered$known_zscores, + input_data$ldMatrix + ), + "refPanel and knownZscores must be in increasing order of pos" + ) }) test_that("raiss refuses a plain list of block matrices", { @@ -247,12 +320,17 @@ test_that("raiss takes an LdMatrix and uses its variants", { 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") + # No refPanel: the LdMatrix's own variants supply it. The z-scores' + # chromosomes are read in UCSC style, so "1" and "chr1" both meet them; + # z-scores on a chromosome the reference lacks have nothing to impute + # from. expect_error( - raiss(knownZscores = chr, ldMatrix = ld, verbose = FALSE), - "chromosome labels" + raiss( + knownZscores = transform(known, chrom = "2"), + ldMatrix = ld, + verbose = FALSE + ), + "shares no chromosome with the LD reference" ) fromLd <- raiss( knownZscores = known, @@ -265,12 +343,74 @@ test_that("raiss takes an LdMatrix and uses its variants", { arrange(fromLd$resultNofilter, variant_id)$z, arrange(full$resultNofilter, variant_id)$z ) + fromChr <- raiss( + knownZscores = transform(known, chrom = "chr1"), + ldMatrix = ld, + r2Threshold = 0.3, + minimumLd = 1, + verbose = FALSE + ) + expect_equal(fromChr, fromLd) expect_error( raiss(knownZscores = known, genotypes = ld), "must be a genotype panel or a GenotypeMixture" ) }) +test_that("raiss takes a summary-statistics GRanges as knownZscores", { + 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)) + # One entry as sumStats() returns it: the variants as ranges, the + # statistics as SNP / A1 / A2 / Z columns. + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(known$pos, width = 1L), + SNP = known$variant_id, + A1 = known$A1, + A2 = known$A2, + Z = known$z + ) + fromTable <- raiss( + ref_panel, + known, + ldMatrix = R, + r2Threshold = 0.3, + minimumLd = 1, + verbose = FALSE + ) + fromRanges <- raiss( + ref_panel, + gr, + ldMatrix = R, + r2Threshold = 0.3, + minimumLd = 1, + verbose = FALSE + ) + expect_equal( + arrange(fromRanges$resultNofilter, variant_id)$z, + arrange(fromTable$resultNofilter, variant_id)$z + ) + expect_equal( + arrange(fromRanges$resultFilter, variant_id)$variant_id, + arrange(fromTable$resultFilter, variant_id)$variant_id + ) + expect_error( + raiss(ref_panel, gr[, "Z"], ldMatrix = R), + "lacks column\\(s\\) SNP, A1, A2" + ) +}) + test_that("Default parameters for raiss work correctly", { input_data <- generateDummyData() result <- raiss( @@ -328,21 +468,6 @@ test_that("Test Default Parameters for raissModel", { expect_true(all(result$raissLdScore >= 0)) }) -test_that("Test with Different lamb Values for raissModel", { - zt <- c(1.2, 0.5) - sig_t <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) - sig_i_t <- matrix(c(0.5, 0.2, 0.2, 0.5), nrow = 2) - - lamb_values <- c(0.01, 0.05, 0.1) - for (lamb in lamb_values) { - result <- raissModel(zt, sig_t, sig_i_t, lamb) - expect_true(is.list(result)) - expect_true(all(c("var", "mu", "raissLdScore") %in% names(result))) - expect_true(is.numeric(result$mu)) - expect_true(all(is.finite(result$mu))) - } -}) - test_that("Report Condition Number in raissModel", { zt <- c(1.2, 0.5) sig_t <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) @@ -377,9 +502,18 @@ test_that("Input Validation of raissModel", { sig_t_invalid <- "not a matrix" sig_i_t_invalid <- "not a matrix" - expect_error(raissModel(zt_invalid, sig_t, sig_i_t)) - expect_error(raissModel(zt, sig_t_invalid, sig_i_t)) - expect_error(raissModel(zt, sig_t, sig_i_t_invalid)) + expect_error( + raissModel(zt_invalid, sig_t, sig_i_t), + "Assertion on 'zt' failed: Must be of type 'numeric'" + ) + expect_error( + raissModel(zt, sig_t_invalid, sig_i_t), + "Assertion on 'sigT' failed: Must be of type 'numeric'" + ) + expect_error( + raissModel(zt, sig_t, sig_i_t_invalid), + "Assertion on 'sigIT' failed: Must be of type 'numeric'" + ) }) test_that("Boundary Conditions of raissModel", { @@ -391,33 +525,18 @@ test_that("Boundary Conditions of raissModel", { sig_t_empty <- matrix(numeric(0), nrow = 0) sig_i_t_empty <- matrix(numeric(0), nrow = 0) - expect_error(raissModel(zt_empty, sig_t, sig_i_t)) - expect_error(raissModel(zt, sig_t_empty, sig_i_t)) - expect_error(raissModel(zt, sig_t, sig_i_t_empty)) -}) - -test_that("Test with Different rcond Values for raissModel", { - zt <- c(1.2, 0.5) - sig_t <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) - sig_i_t <- matrix(c(0.5, 0.2, 0.2, 0.5), nrow = 2) - - rcond_values <- c(0.01, 0.05, 0.1) - for (rcond in rcond_values) { - result <- raissModel(zt, sig_t, sig_i_t, lamb = 0.01, rcond = rcond) - expect_true(is.list(result)) - expect_true(all( - c( - "var", - "mu", - "raissLdScore", - "conditionNumber", - "correctInversion" - ) %in% - names(result) - )) - expect_true(is.numeric(result$mu)) - expect_true(all(is.finite(result$mu))) - } + expect_error( + raissModel(zt_empty, sig_t, sig_i_t), + "Assertion on 'zt' failed: Must have length >= 1" + ) + expect_error( + raissModel(zt, sig_t_empty, sig_i_t), + "Assertion on 'sigT' failed: Must have exactly 2 rows" + ) + expect_error( + raissModel(zt, sig_t, sig_i_t_empty), + "Assertion on 'sigIT' failed: Must have at least 1 rows" + ) }) test_that("formatRaissDf returns correctly formatted data frame", { @@ -543,16 +662,6 @@ test_that("raissR2 is calculated correctly in filterRaissOutput", { expect_equal(output$raissR2, expected_R2[which(expected_R2 > 0.6)]) }) -test_that("Filtering is applied correctly in filterRaissOutput", { - test_data <- generateFroTestData() - R2_threshold <- 0.6 - minimum_ld <- 5 - output <- filterRaissOutput(test_data, R2_threshold, minimum_ld)$zscores - - expect_true(all(output$raissR2 > R2_threshold)) - expect_true(all(output$raissLdScore >= minimum_ld)) -}) - test_that("Function returns the correct subset in filterRaissOutput", { test_data <- generateFroTestData() test_data$raissR2 <- 1 - test_data$Var @@ -586,34 +695,25 @@ generateMockDataForComputeVar <- function(seed = 1) { ) } -test_that("computeVar returns correct output for batch = TRUE", { +test_that("computeVar returns var and raissLdScore with and without batch", { input_data <- generateMockDataForComputeVar() - result <- computeVar( - input_data$sig_i_t_1, - input_data$sig_t_inv_1, - input_data$lamb_1, - batch = TRUE - ) - expect_true(is.list(result)) - expect_length(result, 2) - expect_true(all(c("var", "raissLdScore") %in% names(result))) - expect_true(is.numeric(result$var)) - expect_true(is.numeric(result$raissLdScore)) -}) - -test_that("computeVar returns correct output for batch = FALSE", { - input_data <- generateMockDataForComputeVar() - result <- computeVar( - input_data$sig_i_t_1, - input_data$sig_t_inv_1, - input_data$lamb_1, - batch = FALSE - ) - expect_true(is.list(result)) - expect_length(result, 2) - expect_true(all(c("var", "raissLdScore") %in% names(result))) - expect_true(is.numeric(result$var)) - expect_true(is.numeric(result$raissLdScore)) + for (batch in c(TRUE, FALSE)) { + result <- computeVar( + input_data$sig_i_t_1, + input_data$sig_t_inv_1, + input_data$lamb_1, + batch = batch + ) + lbl <- str_c("batch = ", batch) + expect_true(is.list(result), info = lbl) + expect_length(result, 2) + expect_true( + all(c("var", "raissLdScore") %in% names(result)), + info = lbl + ) + expect_true(is.numeric(result$var), info = lbl) + expect_true(is.numeric(result$raissLdScore), info = lbl) + } }) test_that("checkInversion correctly identifies inverse matrices in", { @@ -635,50 +735,110 @@ test_that("varInBoundaries sets boundaries correctly", { result <- varInBoundaries(var, lamb_test) - expect_equal(result[1], 0) # Value less than 0 should be set to 0 - expect_equal(result[2], 0) # Value within lower boundary should remain unchanged - expect_equal(result[3], 0.5) # Value within boundaries should remain unchanged - expect_equal(result[4], 1.04) # Value greater than 0.99999 + lamb should be set to 1 - expect_equal(result[5], 1) # Value greater than 0.99999 + lamb should be set to 1 + # Below 0 is floored to 0; above 0.99999 + lamb is capped to 1; anything + # in between, the bounds included, is unchanged. + expect_equal(result[1], 0) + expect_equal(result[2], 0) + expect_equal(result[3], 0.5) + expect_equal(result[4], 1.04) + expect_equal(result[5], 1) }) test_that("invertMat computes correct pseudo-inverse", { + # The diagonal is replaced by 1 + lamb, not added to: what is inverted + # is the ridged matrix. mat <- matrix(c(1, 2, 3, 4), nrow = 2) - lamb <- 0.5 - rcond <- 1e-7 - result <- invertMat(mat, lamb, rcond) - expect_true(is.matrix(result)) + result <- invertMat(mat, lamb = 0.5, rcond = 1e-7) + ridged <- matrix(c(1.5, 2, 3, 1.5), nrow = 2) + expect_equal(ridged %*% result, diag(2)) + expect_equal(result %*% ridged, diag(2)) + # A singular ridged matrix has no inverse; the result is its + # Moore-Penrose pseudo-inverse. + ones <- matrix(1, nrow = 2, ncol = 2) + pinv <- invertMat(ones, lamb = 0, rcond = 1e-7) + expect_equal(pinv, matrix(0.25, nrow = 2, ncol = 2)) + expect_equal(ones %*% pinv %*% ones, ones) + expect_equal(pinv %*% ones %*% pinv, pinv) }) test_that("invertMat handles errors and retries", { - mat <- matrix(c(0, 0, 0, 0), nrow = 2) - lamb <- 0.1 - rcond <- 1e-7 - result <- invertMat(mat, lamb, rcond) - expect_true(is.matrix(result)) + # ginv() can fail, as when LAPACK's SVD does not converge. invertMat() + # then tries once more with the ridge and the cutoff each raised 10%. + ridges <- numeric(0) + tols <- numeric(0) + local_mocked_bindings( + ginv = function(X, tol = sqrt(.Machine$double.eps)) { + ridges <<- c(ridges, X[1, 1]) + tols <<- c(tols, tol) + if (length(tols) == 1L) { + stop("SVD did not converge") + } + MASS::ginv(X, tol = tol) + }, + .package = "pecotmr" + ) + mat <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) + result <- invertMat(mat, lamb = 0.1, rcond = 1e-7) + expect_equal(ridges, c(1.1, 1.11)) + expect_equal(tols, c(1e-7, 1.1e-7)) + # What comes back is the retry's inverse, of the matrix ridged to 1.11. + retried <- matrix(c(1.11, 0.5, 0.5, 1.11), nrow = 2) + expect_equal(retried %*% result, diag(2)) }) test_that("invertMatRecursive correctly inverts a valid square matrix", { mat <- matrix(c(2, -1, -1, 2), nrow = 2) - lamb <- 0.5 - rcond <- 0.01 - result <- invertMatRecursive(mat, lamb, rcond) - expect_true(is.matrix(result)) - expect_equal(dim(result), dim(mat)) + result <- invertMatRecursive(mat, lamb = 0.5, rcond = 0.01) + # What is inverted is mat with its diagonal set to 1 + lamb. + ridged <- matrix(c(1.5, -1, -1, 1.5), nrow = 2) + expect_equal(ridged %*% result, diag(2)) + expect_equal(result %*% ridged, diag(2)) }) -test_that("invertMatRecursive handles non-square matrices appropriately", { +test_that("invertMatRecursive gives a non-square matrix its pseudo-inverse", { mat <- matrix(1:6, nrow = 2) - lamb <- 0.5 - rcond <- 0.01 - expect_silent(invertMatRecursive(mat, lamb, rcond)) -}) - -test_that("invertMatRecursive handles errors and recurses correctly", { - mat <- "not a matrix" - lamb <- 0.5 - rcond <- 0.01 - expect_error(invertMatRecursive(mat, lamb, rcond)) + result <- invertMatRecursive(mat, lamb = 0.5, rcond = 0.01) + # The ridge sets the leading diagonal, [1, 1] and [2, 2]. The ridged + # 2 x 3 matrix A has full row rank, so its Moore-Penrose inverse is the + # right inverse t(A) (A t(A))^-1. + ridged <- matrix(c(1.5, 2, 3, 1.5, 5, 6), nrow = 2) + expect_equal(dim(result), c(3L, 2L)) + expect_equal(ridged %*% result, diag(2)) + expect_equal(result, t(ridged) %*% solve(ridged %*% t(ridged))) +}) + +test_that("invertMatRecursive retries via invertMat, three attempts in all", { + # A failed inversion falls back to invertMat() with lamb and rcond + # raised 10%, which retries once more itself: three attempts, each 10% + # above the last, before the error reaches the caller. + failures <- 2L + ridges <- numeric(0) + tols <- numeric(0) + local_mocked_bindings( + ginv = function(X, tol = sqrt(.Machine$double.eps)) { + ridges <<- c(ridges, X[1, 1]) + tols <<- c(tols, tol) + if (length(tols) <= failures) { + stop("SVD did not converge") + } + MASS::ginv(X, tol = tol) + }, + .package = "pecotmr" + ) + mat <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) + result <- invertMatRecursive(mat, lamb = 0.1, rcond = 0.01) + expect_equal(ridges, 1 + 0.1 * c(1, 1.1, 1.21)) + expect_equal(tols, 0.01 * c(1, 1.1, 1.21)) + lastTry <- matrix(c(1.121, 0.5, 0.5, 1.121), nrow = 2) + expect_equal(lastTry %*% result, diag(2)) + # A third failure is not retried: it reaches the caller. + failures <- 3L + tols <- numeric(0) + expect_error( + invertMatRecursive(mat, lamb = 0.1, rcond = 0.01), + "SVD did not converge" + ) + expect_length(tols, 3L) }) # =========================================================================== @@ -820,10 +980,6 @@ test_that("raissSingleMatrixFromX returns known z when nothing to impute", { expect_null(result$ldMat) }) -# =========================================================================== -# raiss() dispatch paths: single-matrix list and genotype_matrix list -# =========================================================================== - # ============================================================================ # Tests for SVD-based genotype matrix path (raissSingleMatrixFromX) # ============================================================================ @@ -910,7 +1066,7 @@ generateXTestData <- function(n = 200, p = 100, n_known = 50, seed = 42) { ) } -test_that("safeSvd basic functionality", { +test_that(".safeSvd basic functionality", { set.seed(1) mat <- matrix(rnorm(20), nrow = 5, ncol = 4) s <- pecotmr:::.safeSvd(mat) @@ -921,7 +1077,7 @@ test_that("safeSvd basic functionality", { expect_equal(mat, reconstructed, tolerance = 1e-10) }) -test_that("safeSvd filters small singular values", { +test_that(".safeSvd filters small singular values", { set.seed(2) # Create rank-2 matrix u <- matrix(rnorm(10), nrow = 5, ncol = 2) @@ -931,7 +1087,7 @@ test_that("safeSvd filters small singular values", { expect_equal(length(s$d), 2) }) -test_that("safeSvd max_rank works", { +test_that(".safeSvd maxRank works", { set.seed(3) mat <- matrix(rnorm(50), nrow = 10, ncol = 5) s <- pecotmr:::.safeSvd(mat, maxRank = 2) @@ -940,7 +1096,7 @@ test_that("safeSvd max_rank works", { expect_equal(ncol(s$v), 2) }) -test_that("safeSvd rejects all-zero matrix", { +test_that(".safeSvd rejects all-zero matrix", { mat <- matrix(0, nrow = 5, ncol = 3) expect_error(pecotmr:::.safeSvd(mat), "all-zero") }) @@ -1094,36 +1250,6 @@ test_that("the genotype and LD routes drop the same weak directions", { )$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) - - result_R <- raiss( - data$ref_panel, - data$known_zscores, - ldMatrix = data$R, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - result_X <- .raissX( - data$ref_panel, - data$known_zscores, - data$X, - lamb = 0.01, - svdTol = 1e-12, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - - r_sorted <- result_R$resultNofilter %>% arrange(variant_id) - x_sorted <- result_X$resultNofilter %>% arrange(variant_id) - - expect_equal(r_sorted$z, x_sorted$z, tolerance = 1e-4) - expect_equal(r_sorted$Var, x_sorted$Var, tolerance = 1e-4) -}) test_that("X path matches R path: varying lambda", { data <- generateXTestData(n = 150, p = 80, n_known = 40, seed = 7) @@ -1168,27 +1294,6 @@ test_that("X path matches R path: varying lambda", { } }) -test_that("X path handles all-known edge case", { - data <- generateXTestData(n = 100, p = 50, n_known = 50, seed = 10) - # Make all variants known - all_known <- data.frame( - chrom = data$ref_panel$chrom, - pos = data$ref_panel$pos, - variant_id = data$ref_panel$variant_id, - A1 = data$ref_panel$A1, - A2 = data$ref_panel$A2, - z = rnorm(nrow(data$ref_panel)), - stringsAsFactors = FALSE - ) - result <- .raissX( - data$ref_panel, - all_known, - data$X, - verbose = FALSE - ) - expect_equal(nrow(result$resultNofilter), nrow(data$ref_panel)) -}) - test_that("X path handles single unknown variant", { data <- generateXTestData(n = 100, p = 50, n_known = 49, seed = 15) @@ -1426,121 +1531,34 @@ test_that("the SVD route reports its progress when verbose", { expect_equal(nrow(res$resultNofilter), nrow(data$ref_panel)) }) -test_that("X path with collinear variants matches R path", { - set.seed(55) - n <- 150 - p <- 60 - # Create X with some near-duplicate columns - X_raw <- matrix( - sample(0:2, n * p, replace = TRUE, prob = c(0.25, 0.5, 0.25)), - nrow = n, - ncol = p - ) - # Make columns 5 and 6 nearly identical - X_raw[, 6] <- X_raw[, 5] + sample(c(0, 0, 0, 0, 1), n, replace = TRUE) - X_raw[X_raw > 2] <- 2 - - X <- scale(X_raw) - X[is.na(X)] <- 0 +context("slalom") - ref_panel <- data.frame( - chrom = rep(1, p), - pos = seq(1, p * 10, 10), - variant_id = paste0("rs", seq_len(p)), - A1 = rep("A", p), - A2 = rep("G", p), - stringsAsFactors = FALSE +# ============================================================================ +# Helper: build a valid positive-definite LD matrix from a genotype matrix +# ============================================================================ +makeSyntheticLd <- function(n_samples, n_snps, seed = 1) { + set.seed(seed) + # Simulate genotypes with some LD structure by using a factor model + # X = Z %*% L + noise, where Z is latent and L is a loading matrix + n_factors <- min(3, n_snps) + Z <- matrix(rnorm(n_samples * n_factors), nrow = n_samples) + L <- matrix(runif(n_factors * n_snps, -1, 1), nrow = n_factors) + X_raw <- Z %*% + L + + matrix(rnorm(n_samples * n_snps, sd = 0.5), nrow = n_samples) + # Discretise to genotype-like values (0, 1, 2) + X <- matrix( + as.integer(cut(X_raw, breaks = c(-Inf, -0.5, 0.5, Inf))) - 1L, + nrow = n_samples, + ncol = n_snps ) - colnames(X) <- ref_panel$variant_id - - n_known <- 30 - known_idx <- sort(sample(seq_len(p), 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 <- cor(X_raw) - R[is.na(R)] <- 0 - colnames(R) <- rownames(R) <- ref_panel$variant_id - - result_R <- raiss( - ref_panel, - known_zscores, - ldMatrix = R, - lamb = 0.01, - rcond = 0.01, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - result_X <- .raissX( - ref_panel, - known_zscores, - X, - lamb = 0.01, - svdTol = 1e-12, - r2Threshold = 0, - minimumLd = 0, - verbose = FALSE - ) - - r_sorted <- result_R$resultNofilter %>% arrange(variant_id) - x_sorted <- result_X$resultNofilter %>% arrange(variant_id) - - expect_equal( - r_sorted$z, - x_sorted$z, - tolerance = 1e-3, - info = "Collinear case: z-scores should be close" - ) -}) - -context("RAISS missing-variant imputation in TWAS pipelines") - -# Previous tests covered `twasWeightsSumstatPipeline(imputeMissing = ...)`, -# which has been removed in favor of the S4 `twasWeightsPipeline` family -# dispatching on `QtlSumStats` / `QtlDataset`. The missing-variant -# imputation knob now lives inside `summaryStatsQc(impute = TRUE)`, and -# tests for that path live in test_sumstatsQc.R (internal helpers) and -# in the SumStats pipeline tests. -# -# RAISS itself (`raiss()`) still exists with the same signature; its -# direct tests live in test_raiss.R. - -context("slalom") - -# ============================================================================ -# Helper: build a valid positive-definite LD matrix from a genotype matrix -# ============================================================================ -makeSyntheticLd <- function(n_samples, n_snps, seed = 1) { - set.seed(seed) - # Simulate genotypes with some LD structure by using a factor model - # X = Z %*% L + noise, where Z is latent and L is a loading matrix - n_factors <- min(3, n_snps) - Z <- matrix(rnorm(n_samples * n_factors), nrow = n_samples) - L <- matrix(runif(n_factors * n_snps, -1, 1), nrow = n_factors) - X_raw <- Z %*% - L + - matrix(rnorm(n_samples * n_snps, sd = 0.5), nrow = n_samples) - # Discretise to genotype-like values (0, 1, 2) - X <- matrix( - as.integer(cut(X_raw, breaks = c(-Inf, -0.5, 0.5, Inf))) - 1L, - nrow = n_samples, - ncol = n_snps - ) - colnames(X) <- paste0("snp", seq_len(n_snps)) - R <- cor(X) - # Ensure perfect diagonal and clean NaN from any zero-variance columns - R[is.na(R) | is.nan(R)] <- 0 - diag(R) <- 1.0 - list(X = X, R = R) -} + colnames(X) <- paste0("snp", seq_len(n_snps)) + R <- cor(X) + # Ensure perfect diagonal and clean NaN from any zero-variance columns + R[is.na(R) | is.nan(R)] <- 0 + diag(R) <- 1.0 + list(X = X, R = R) +} # ============================================================================ # Basic output structure @@ -1622,7 +1640,10 @@ test_that("slalom still refuses both or neither of R and X", { R <- diag(4) X <- matrix(rnorm(40), nrow = 10, ncol = 4) expect_error(slalom(zScore = z), "Either R .* or X .* must be provided") - expect_error(slalom(zScore = z, R = R, X = X), "not both") + expect_error( + slalom(zScore = z, R = R, X = X), + "Provide either R or X, not both" + ) }) test_that("slalom accepts X matrix instead of R", { @@ -1707,22 +1728,6 @@ test_that("ABF: lbf formula matches manual calculation", { expect_equal(actual_ratio, expected_ratio, tolerance = 1e-10) }) -test_that("ABF: PIPs always sum to exactly 1", { - for (s in 1:5) { - set.seed(200 + s) - n <- sample(5:30, 1) - z <- rnorm(n, sd = 2) - R <- diag(n) - result <- slalom(zScore = z, R = R) - expect_equal( - sum(result$data$prob), - 1, - tolerance = 1e-12, - label = paste("seed", 200 + s) - ) - } -}) - test_that("ABF: symmetric z-scores give symmetric PIPs", { z <- c(-3, 3) R <- diag(2) @@ -1746,6 +1751,8 @@ test_that("CS95 contains the causal variant in a simple synthetic signal", { expect_true(causal %in% result$summary$cs95) expect_true(causal %in% result$summary$cs99) + # ... and, as the top-PIP variant, it heads the CS. + expect_equal(result$summary$cs95[1], causal) }) test_that("CS99 is a superset of CS95", { @@ -1776,20 +1783,6 @@ test_that("CS95 covers at least 95% of posterior mass", { expect_gt(cs99_mass, 0.99) }) -test_that("CS with very strong signal contains only the causal variant", { - set.seed(303) - n <- 15 - z <- rnorm(n, sd = 0.1) - z[8] <- 15 # extremely strong - R <- diag(n) - - result <- slalom(zScore = z, R = R) - - expect_equal(result$summary$cs95[1], 8) - expect_true(8 %in% result$summary$cs95) - expect_true(8 %in% result$summary$cs99) -}) - test_that("CS with diffuse signal contains many variants", { set.seed(304) n <- 10 @@ -1806,25 +1799,8 @@ test_that("CS with diffuse signal contains many variants", { # Lead variant by pvalue vs abf # ============================================================================ -test_that("lead variant by pvalue selects most negative z-score", { - z <- c(0, -4, 3, -1, 2) - R <- diag(5) - - result <- slalom(zScore = z, R = R, leadVariantChoice = "pvalue") - - expect_equal(result$summary$leadPipVariant, 2) -}) - -test_that("lead variant by abf selects highest PIP", { - z <- c(0, -4, 3, -1, 2) - R <- diag(5) - - result <- slalom(zScore = z, R = R, leadVariantChoice = "abf") - - expect_equal(result$summary$leadPipVariant, which.max(result$data$prob)) -}) - -test_that("pvalue and abf lead can differ when z has asymmetric magnitudes", { +test_that("pvalue lead is the most negative z, abf lead the highest PIP", { + # Asymmetric magnitudes, so the two choices disagree. z <- c(-3.0, 5.0, 0.1, -0.2, 0.3) R <- diag(5) @@ -1833,6 +1809,10 @@ test_that("pvalue and abf lead can differ when z has asymmetric magnitudes", { expect_equal(result_pv$summary$leadPipVariant, 1) expect_equal(result_abf$summary$leadPipVariant, 2) + expect_equal( + result_abf$summary$leadPipVariant, + which.max(result_abf$data$prob) + ) expect_false( result_pv$summary$leadPipVariant == result_abf$summary$leadPipVariant ) @@ -1978,28 +1958,6 @@ test_that("edge case: all zero z-scores", { expect_equal(result$summary$maxPip, 1 / n, tolerance = 1e-14) }) -test_that("edge case: very large z-scores do not produce NaN in PIPs", { - z <- c(50, -50, 30, -30, 0) - R <- diag(5) - - result <- slalom(zScore = z, R = R) - - expect_false(any(is.nan(result$data$prob))) - expect_false(any(is.na(result$data$prob))) - expect_equal(sum(result$data$prob), 1, tolerance = 1e-10) - expect_equal(result$data$prob[1], result$data$prob[2], tolerance = 1e-14) -}) - -test_that("edge case: identical z-scores yield uniform PIPs", { - n <- 8 - z <- rep(2.5, n) - R <- diag(n) - - result <- slalom(zScore = z, R = R) - - expect_equal(result$data$prob, rep(1 / n, n), tolerance = 1e-14) -}) - test_that("edge case: two variants only", { z <- c(-3, 2) R <- matrix(c(1, 0.5, 0.5, 1), nrow = 2) @@ -2012,68 +1970,6 @@ test_that("edge case: two variants only", { expect_gt(result$data$prob[1], result$data$prob[2]) }) -test_that("edge case: mismatched dimensions error", { - z <- rnorm(10) - R <- diag(5) - expect_error( - slalom(zScore = z, R = R), - "R.*Must have exactly 10 rows" - ) -}) - -test_that("edge case: no R and no X provided errors", { - z <- rnorm(5) - expect_error(slalom(zScore = z), "Either R.*or X.*must be provided") -}) - -test_that("edge case: both R and X provided errors", { - set.seed(500) - n <- 5 - z <- rnorm(n) - R <- diag(n) - X <- matrix(sample(0:2, 50 * n, replace = TRUE), nrow = 50, ncol = n) - expect_error( - slalom(zScore = z, R = R, X = X), - "Provide either R or X, not both" - ) -}) - -# ============================================================================ -# X input mode -# ============================================================================ - -test_that("X input yields same result as R = cor(X)", { - set.seed(600) - n_samples <- 200 - n_snps <- 10 - X <- matrix( - sample(0:2, n_samples * n_snps, replace = TRUE), - nrow = n_samples, - ncol = n_snps - ) - colnames(X) <- paste0("snp", seq_len(n_snps)) - z <- rnorm(n_snps, sd = 2) - - R_manual <- cor(X) - diag(R_manual) <- 1.0 - - result_X <- slalom(zScore = z, X = X) - result_R <- slalom(zScore = z, R = R_manual) - - expect_equal(result_X$data$prob, result_R$data$prob, tolerance = 1e-10) - expect_equal( - result_X$data$original_z, - result_R$data$original_z, - tolerance = 1e-14 - ) - expect_equal( - result_X$summary$leadPipVariant, - result_R$summary$leadPipVariant - ) - expect_equal(result_X$summary$cs95, result_R$summary$cs95) - expect_equal(result_X$summary$cs99, result_R$summary$cs99) -}) - # ============================================================================ # Parameter variation # ============================================================================ @@ -2127,30 +2023,6 @@ test_that("r2_threshold variation affects n_r2 count", { expect_gte(result_low$summary$nR2, result_high$summary$nR2) }) -test_that("nlog10p_dentist_s_threshold variation affects outlier count", { - set.seed(702) - n <- 10 - syn <- makeSyntheticLd(200, n, seed = 702) - z <- rnorm(n, sd = 2) - z[1] <- -6 - - result_low_thresh <- slalom( - zScore = z, - R = syn$R, - nlog10pDentistSThreshold = 1.0 - ) - result_high_thresh <- slalom( - zScore = z, - R = syn$R, - nlog10pDentistSThreshold = 10.0 - ) - - expect_gte( - result_low_thresh$summary$nDentistSOutlier, - result_high_thresh$summary$nDentistSOutlier - ) -}) - # ============================================================================ # Output structure validation # ============================================================================ @@ -2227,21 +2099,6 @@ test_that("fraction = 0 with no outliers (identity LD, consistent z)", { expect_equal(result$summary$fraction, 0) }) -test_that("fraction is between 0 and 1", { - set.seed(900) - for (s in 1:5) { - set.seed(900 + s) - n <- sample(10:30, 1) - syn <- makeSyntheticLd(200, n, seed = 900 + s) - z <- rnorm(n, sd = 2) - z[1] <- -6 - - result <- slalom(zScore = z, R = syn$R, r2Threshold = 0.3) - expect_gte(result$summary$fraction, 0) - expect_lte(result$summary$fraction, 1) - } -}) - test_that("maxPip equals the maximum of prob vector", { set.seed(901) n <- 20 @@ -2273,38 +2130,34 @@ test_that("realistic LD: correlated variants share PIP mass", { }) test_that("realistic LD: DENTIST-S detects outlier in correlated block", { - set.seed(1001) - syn <- makeSyntheticLd(500, 15, seed = 1001) - R <- syn$R - - lead_idx <- 1 - z <- R[, lead_idx] * (-5) - z[1] <- -5 - - r2_to_lead <- R[, 1]^2 - candidates <- which(r2_to_lead > 0.3 & seq_along(z) != 1) - if (length(candidates) > 0) { - corrupt_idx <- candidates[1] - z[corrupt_idx] <- z[corrupt_idx] + 10 + # LD decaying with distance from the lead, r = 0.9^d, so its neighbour + # is in LD with it by construction (r2 = 0.81, above the 0.2 cutoff). + p <- 15L + R <- 0.9^abs(outer(seq_len(p), seq_len(p), "-")) + # Every z-score as the lead's LD predicts it, then the neighbour's + # corrupted by +10. + z <- R[, 1] * (-5) + z[2] <- z[2] + 10 - result <- slalom( - zScore = z, - R = R, - r2Threshold = 0.2, - nlog10pDentistSThreshold = 3.0 - ) + result <- slalom( + zScore = z, + R = R, + r2Threshold = 0.2, + nlog10pDentistSThreshold = 3.0 + ) - expect_true(result$data$outliers[corrupt_idx]) - } + expect_equal(result$summary$leadPipVariant, 1L) + # The corrupted variant, and only it, is flagged. + expect_equal(which(result$data$outliers), 2L) }) test_that("realistic LD: no outliers when z perfectly matches LD structure", { - set.seed(1002) - syn <- makeSyntheticLd(500, 10, seed = 1002) - R <- syn$R - - lead_idx <- 1 - z <- R[, lead_idx] * (-4) + # LD decaying with distance from the lead, r = 0.9^d: the lead and + # variants 2-6 clear the 0.3 r2 cutoff, so only their DENTIST-S + # statistic keeps them from being flagged. + p <- 10L + R <- 0.9^abs(outer(seq_len(p), seq_len(p), "-")) + z <- R[, 1] * (-4) result <- slalom( zScore = z, @@ -2313,57 +2166,13 @@ test_that("realistic LD: no outliers when z perfectly matches LD structure", { nlog10pDentistSThreshold = 4.0 ) - non_lead <- setdiff(seq_along(z), result$summary$leadPipVariant) - lead <- result$summary$leadPipVariant - for (i in non_lead) { - r2_val <- R[i, lead]^2 - if (r2_val > 0.3 && r2_val < 1.0) { - expect_false(result$data$outliers[i]) - } else if (r2_val >= 1.0) { - expect_true( - is.na(result$data$outliers[i]) || !result$data$outliers[i] - ) - } - } -}) - -# ============================================================================ -# Internal function access (resolveLdInput, pecotmr internal) -# ============================================================================ - -test_that("resolveLdInput returns R when R is provided", { - R <- diag(5) - res <- pecotmr:::resolveLdInput(R = R, needNSample = FALSE) - expect_equal(res$R, R) -}) - -test_that("resolveLdInput computes R from X", { - set.seed(1100) - X <- matrix(sample(0:2, 200 * 5, replace = TRUE), nrow = 200, ncol = 5) - colnames(X) <- paste0("s", 1:5) - res <- pecotmr:::resolveLdInput(X = X, needNSample = FALSE) - expect_true(is.matrix(res$R)) - expect_equal(nrow(res$R), 5) - expect_equal(ncol(res$R), 5) - for (j in seq_len(5)) { - expect_equal(res$R[j, j], 1.0, tolerance = 1e-6) - } -}) - -test_that("resolveLdInput errors when neither R nor X given", { - expect_error( - pecotmr:::resolveLdInput(R = NULL, X = NULL), - "Either R.*or X.*must be provided" - ) -}) - -test_that("resolveLdInput errors when both R and X given", { - R <- diag(3) - X <- matrix(1, nrow = 10, ncol = 3) - expect_error( - pecotmr:::resolveLdInput(R = R, X = X), - "Provide either R or X, not both" - ) + expect_equal(result$summary$leadPipVariant, 1L) + expect_equal(result$summary$nR2, 6L) + # Each z is exactly what the lead's LD predicts, so every statistic is 0 + # and nothing is flagged. + expect_equal(result$data$nlog10p_dentist_s[-1], rep(0, p - 1L)) + expect_false(any(result$data$outliers[-1])) + expect_equal(result$summary$nDentistSOutlier, 0L) }) # ============================================================================ @@ -2376,7 +2185,7 @@ test_that("log-sum-exp trick prevents overflow with extreme z-scores", { result <- slalom(zScore = z, R = R) - expect_false(any(is.nan(result$data$prob))) + expect_false(any(is.na(result$data$prob))) expect_false(any(is.infinite(result$data$prob))) expect_equal(sum(result$data$prob), 1, tolerance = 1e-10) expect_equal(result$data$prob[1], result$data$prob[3], tolerance = 1e-14) @@ -2449,25 +2258,6 @@ context("summaryStatsQc") # Fixture builders # =========================================================================== -.ssQ_makeHandle <- function(snp_n = 8L, n_samples = 60L) { - new( - "GenotypeHandle", - path = "/tmp/sketch", - format = "plink2", - snpInfo = data.frame( - SNP = paste0("rs", 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 - ) -} - .ssQ_makeEntryGr <- function( snp_ids = paste0("rs", 1:4), positions = c(100L, 200L, 300L, 400L) @@ -2638,14 +2428,6 @@ test_that("summaryStatsQc: PIP screen off leaves the harmonized set intact", { expect_setequal(snps, c("chr1:100:G:A", "chr1:200:G:A", "chr1:300:G:A")) }) -# A panel whose SNP ids follow the formatVariantId convention (chr:pos:A2:A1), -# as real genotype LD sketches do, so a re-keyed entry SNP resolves against it. -.ssQ_makeHandleVid <- function(snp_n = 8L, n_samples = 60L) { - h <- .ssQ_makeHandle(snp_n, n_samples) - h@snpInfo$SNP <- paste0("chr1:", snpInfo(h)$BP, ":G:A") - h -} - # Entry with one allele-swapped variant (pos 200: A1/A2 reversed vs the panel), # carrying its input-orientation SNP. Others are exact matches. .ssQ_makeFlipEntryGr <- function() { @@ -2691,18 +2473,6 @@ test_that("summaryStatsQc: harmonization re-keys SNP and sign-flips Z", { # never drop the variant # --------------------------------------------------------------------------- -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:::.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:::.ldRefVariantIds(h)[-2L]) - # the raw accessor still answers the panel FILE's label (.afreq keys on it) - expect_equal(pecotmr:::.ldRefVariantIds(h)[2L], "chr1:200:INS:A") -}) - test_that(".raissUnsafeToImpute does not refuse a tag-allele id", { # A tag id is repaired at the panel boundary, so RAISS sees a normal indel # id; only the flip-pair / flip-of-known ambiguities are unsafe. @@ -2761,7 +2531,7 @@ test_that("a tag-named panel entry survives the end-to-end sketch subset", { 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:::.ldRefMatchIds(ldReference(out)) + "chr1:200:G:A" %in% pecotmr:::.ldRefMatchIds(ldReference(out)[[1L]]) ) }) @@ -2789,7 +2559,7 @@ test_that("the sketch survives a chr:pos:A1:A2 panel (PLINK .bim order)", { signalScreenParam = SignalScreenParam(pip = 0), sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - kept <- pecotmr:::.ldRefMatchIds(ldReference(out)) + kept <- pecotmr:::.ldRefMatchIds(ldReference(out)[[1L]]) expect_length(kept, 4L) expect_setequal( pecotmr:::parseVariantId(kept)$pos, @@ -2932,32 +2702,41 @@ test_that(".deriveBetaSeFromZ: skipped when N missing", { # summaryStatsQc: end-to-end on the synthetic fixture # =========================================================================== -test_that("summaryStatsQc: vanilla run fills qcInfo, returns GwasSumStats", { +test_that("summaryStatsQc: vanilla run records its options and audits", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss) expect_s4_class(res, "GwasSumStats") - qc <- qcInfo(res) - expect_true(length(qc) > 0L) - expect_true("options" %in% names(qc)) - expect_true("entryAudit" %in% names(qc)) - expect_equal(length(qc$entryAudit), nrow(ss)) - ea <- qc$entryAudit[[1L]] + expect_true("options" %in% names(qcOptions(res))) + expect_false("entryAudit" %in% names(qcOptions(res))) + expect_equal(length(res$qcAudit), nrow(ss)) + ea <- res$qcAudit[[1L]] expect_equal(ea$variantsIn, 4L) expect_equal(ea$variantsOut, 4L) + expect_equal(ea$matchedAgainstLdReference, 4L) + # The per-row table: identity columns, then the audit's scalar counts. + tbl <- qcInfo(res) + expect_s4_class(tbl, "DataFrame") + expect_equal(nrow(tbl), nrow(ss)) + expect_equal(tbl$study, as.character(res$study)) + expect_equal(tbl$variantsIn, 4L) + expect_equal(tbl$variantsOut, 4L) }) test_that("summaryStatsQc: keepVariants subsets entries, records the drop", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc(ss, keepVariants = c("rs1", "rs3")) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$keepVariantsDropped, 2L) expect_equal(ea$variantsOut, 2L) }) test_that("summaryStatsQc: skipRegion drops overlapping variants", { ss <- .ssQ_makeGwasSumStats() - res <- summaryStatsQc(ss, skipRegion = "chr1:50-150") - ea <- qcInfo(res)$entryAudit[[1L]] + res <- summaryStatsQc( + ss, + skipRegion = GenomicRanges::GRanges("chr1:50-150") + ) + ea <- res$qcAudit[[1L]] expect_equal(ea$skipRegionDropped, 1L) # rs1 at pos 100 is dropped }) @@ -2973,19 +2752,12 @@ test_that("summaryStatsQc: PIP screen triggers when no variant has signal", { ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss, signalScreenParam = SignalScreenParam(pip = 0.99)) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_true(isTRUE(ea$pipScreenSkipped)) expect_match(ea$pipScreenReason, "no signals above PIP threshold") expect_equal(length(res[[1L]]), 0L) }) -test_that("summaryStatsQc: harmonized variants count is recorded", { - ss <- .ssQ_makeGwasSumStats() - res <- summaryStatsQc(ss) - ea <- qcInfo(res)$entryAudit[[1L]] - expect_equal(ea$matchedAgainstLdReference, 4L) -}) - test_that("summaryStatsQc: options block records the curated knobs", { ss <- .ssQ_makeGwasSumStats() res <- summaryStatsQc( @@ -2996,7 +2768,7 @@ test_that("summaryStatsQc: options block records the curated knobs", { nCutoff = 10 ) ) - opts <- qcInfo(res)$options + opts <- qcOptions(res)$options expect_true(opts$removeIndels) expect_false(opts$removeStrandAmbiguous) expect_equal(opts$nCutoff, 10) @@ -3014,7 +2786,7 @@ test_that("summaryStatsQc: round-trips QtlSumStats inputs", { ) res <- summaryStatsQc(ss) expect_s4_class(res, "QtlSumStats") - expect_equal(length(qcInfo(res)$entryAudit), 1L) + expect_equal(length(res$qcAudit), 1L) }) # =========================================================================== @@ -3089,7 +2861,7 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts, no N -> N == N_eff", { res <- summaryStatsQc(ss) # 4*case*control/(case+control) per variant. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(360, 640, 510, 750)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(res$qcAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { @@ -3104,18 +2876,17 @@ test_that("summaryStatsQc(effectiveN=TRUE): counts + N -> counts win", { genome = "hg19", ldReference = .ssQ_makeHandle() ) - expect_message(summaryStatsQc(ss), "overridden by effective N") - res <- summaryStatsQc(ss) + expect_message(res <- summaryStatsQc(ss), "overridden by effective N") # N (was 1000) is replaced by the per-variant N_eff. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(360, 640, 510, 750)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(res$qcAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc(effectiveN=TRUE): N only, no counts -> used as-is", { ss <- .ssQ_makeGwasSumStats() # entry carries N = 1000, no counts res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(res$qcAudit[[1L]]$nSource, "column") }) test_that("summaryStatsQc(effectiveN=FALSE): counts + N -> raw N", { @@ -3132,7 +2903,7 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts + N -> raw N", { ) res <- summaryStatsQc(ss, effectiveN = FALSE) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(res$qcAudit[[1L]]$nSource, "column") }) test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { @@ -3149,7 +2920,7 @@ test_that("summaryStatsQc(effectiveN=FALSE): counts -> raw total", { res <- summaryStatsQc(ss, effectiveN = FALSE) # Raw total n_case + n_control per variant. expect_equal(.ssQ_entryNByPos(res[[1L]]), c(1000, 1000, 1000, 1000)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "total") + expect_identical(res$qcAudit[[1L]]$nSource, "total") }) test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { @@ -3163,11 +2934,10 @@ test_that("summaryStatsQc(effectiveN=TRUE): study scalars fill all variants", { nCase = 100, nControl = 900 ) - expect_message(summaryStatsQc(ss), "from study") - res <- summaryStatsQc(ss) + expect_message(res <- summaryStatsQc(ss), "from study") # 4*100*900/1000 = 360 for every variant. expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 360)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "effective") + expect_identical(res$qcAudit[[1L]]$nSource, "effective") }) test_that("summaryStatsQc: study nSample is the level-4 fallback", { @@ -3185,7 +2955,7 @@ test_that("summaryStatsQc: study nSample is the level-4 fallback", { ) res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 4321)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "study-n") + expect_identical(res$qcAudit[[1L]]$nSource, "study-n") }) test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { @@ -3208,7 +2978,7 @@ test_that("summaryStatsQc: QtlSumStats tuple nSample falls back too", { res <- summaryStatsQc(ss) expect_s4_class(res, "QtlSumStats") expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 838)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "study-n") + expect_identical(res$qcAudit[[1L]]$nSource, "study-n") expect_equal(as.numeric(res$nSample), 838) # slot preserved through QC }) @@ -3227,7 +2997,7 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { ) res1 <- summaryStatsQc(ss1) expect_equal(.ssQ_entryNByPos(res1[[1L]]), c(360, 640, 510, 750)) - expect_identical(qcInfo(res1)$entryAudit[[1L]]$nSource, "effective") + expect_identical(res1$qcAudit[[1L]]$nSource, "effective") # per-variant N column present alongside nSample (no counts) -> N wins (column). ss2 <- GwasSumStats( studyName = "g1", @@ -3238,14 +3008,14 @@ test_that("summaryStatsQc: counts beat nSample, and an N column beats it", { ) res2 <- summaryStatsQc(ss2) # .ssQ_makeEntryGr carries N = 1000 expect_true(all(.ssQ_entryNByPos(res2[[1L]]) == 1000)) - expect_identical(qcInfo(res2)$entryAudit[[1L]]$nSource, "column") + expect_identical(res2$qcAudit[[1L]]$nSource, "column") }) -test_that("summaryStatsQc: effectiveN recorded in qcInfo options", { +test_that("summaryStatsQc: effectiveN recorded in qcOptions", { ss <- .ssQ_makeGwasSumStats() - expect_true(qcInfo(summaryStatsQc(ss))$options$effectiveN) + expect_true(qcOptions(summaryStatsQc(ss))$options$effectiveN) expect_false( - qcInfo(summaryStatsQc(ss, effectiveN = FALSE))$options$effectiveN + qcOptions(summaryStatsQc(ss, effectiveN = FALSE))$options$effectiveN ) }) @@ -3263,7 +3033,7 @@ test_that("summaryStatsQc: quantitative QtlSumStats: no effective N", { ) res <- summaryStatsQc(ss) expect_true(all(.ssQ_entryNByPos(res[[1L]]) == 1000)) - expect_identical(qcInfo(res)$entryAudit[[1L]]$nSource, "column") + expect_identical(res$qcAudit[[1L]]$nSource, "column") }) # =========================================================================== @@ -3287,7 +3057,7 @@ test_that("summaryStatsQc: ldMismatchQcMethod 'dentist' walks the LD branch", { .package = "pecotmr" ) res <- suppressWarnings(summaryStatsQc(ss, ldMismatchQcMethod = "dentist")) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$ldMismatchMethod, "dentist") expect_true("ldMismatchOutliersDropped" %in% names(ea)) }) @@ -3339,7 +3109,7 @@ test_that("summaryStatsQc: impute = TRUE invokes RAISS, records counts", { impute = TRUE, raissParam = RaissParam(flank = 500) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) }) @@ -3405,7 +3175,7 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { .package = "pecotmr" ) res <- summaryStatsQc(ss, impute = TRUE) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$raissImputedVariants, 0L) }) @@ -3413,42 +3183,6 @@ test_that("summaryStatsQc: impute with a NULL raiss records 0 imputed", { # summaryStatsQc: per-step QC counter logging (concept salvaged from PR #520) # =========================================================================== -test_that("harmonizeAlleles surfaces sign/strand/dropped in qcCounts", { - # 4 shared positions: 100 exact, 200 sign-flip, 300 strand-flip (A/G - # unambiguous), 400 allele mismatch (dropped). - target <- data.frame( - chrom = c(1, 1, 1, 1), - pos = c(100, 200, 300, 400), - A2 = c("A", "A", "A", "A"), - A1 = c("G", "G", "G", "G"), - z = c(1, 2, 3, 4), - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = c(1, 1, 1, 1), - pos = c(100, 200, 300, 400), - A2 = c("A", "G", "T", "C"), - A1 = c("G", "A", "C", "A"), - stringsAsFactors = FALSE - ) - res <- pecotmr:::harmonizeAlleles( - target, - ref, - colToFlip = "z", - matchMinProp = 0 - ) - # Default return shape unchanged. - expect_named(res, c("harmonizedData", "qcSummary")) - expect_equal(nrow(res$harmonizedData), 3L) - cnt <- attr(res, "qcCounts") - expect_false(is.null(cnt)) - expect_equal(cnt$considered, 4L) - expect_equal(cnt$signFlip, 1L) - expect_equal(cnt$strandFlip, 1L) - expect_equal(cnt$kept, 3L) - expect_equal(cnt$dropped, 1L) -}) - test_that("summaryStatsQc: QC track emits per-step messages and a rollup", { ss <- .ssQ_makeGwasSumStats() local_mocked_bindings( @@ -3524,7 +3258,7 @@ context("sumstatsQc internal helpers") format = "plink2", snpInfo = data.frame( SNP = paste0("rs", seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -3607,7 +3341,7 @@ test_that(".entryGrangesToDf: extracts chrom/pos and all mcols", { gr <- .ssh_makeEntryGr(3, with_extras = TRUE) df <- pecotmr:::.entryGrangesToDf(gr) expect_s3_class(df, "data.frame") - expect_equal(df$chrom, rep("1", 3)) # "chr" stripped + expect_equal(df$chrom, rep("chr1", 3)) expect_equal(df$pos, c(100L, 200L, 300L)) expect_setequal( intersect( @@ -3671,7 +3405,7 @@ test_that("entry GRanges round-trips through df conversion", { test_that(".refVariantsFromLdRef: extracts chr/pos/alleles from snpInfo", { h <- .ssh_makeHandle() rv <- pecotmr:::.refVariantsFromLdRef(h) - expect_equal(rv$chrom, rep("1", 6)) # "chr" stripped + expect_equal(rv$chrom, rep("chr1", 6)) expect_equal(rv$pos, c(100L, 200L, 300L, 400L, 500L, 600L)) expect_equal(rv$variant_id, paste0("rs", 1:6)) expect_equal(rv$A1, rep("A", 6)) @@ -3679,19 +3413,9 @@ test_that(".refVariantsFromLdRef: extracts chr/pos/alleles from snpInfo", { }) # =========================================================================== -# .applySkipRegion +# .applySanityChecks # =========================================================================== -.ssh_smallDf <- function() { - data.frame( - chrom = c("1", "1", "2"), - pos = c(100L, 200L, 100L), - SNP = c("rs1", "rs2", "rs3"), - Z = c(1, 2, 3), - stringsAsFactors = FALSE - ) -} - test_that(".applySanityChecks: empty input is a no-op", { out <- pecotmr:::.applySanityChecks(data.frame(chrom = character())) expect_equal(nrow(out$df), 0L) @@ -3724,7 +3448,7 @@ test_that(".applySanityChecks: normalizeChr maps 23/24/M, drops others", { stringsAsFactors = FALSE ) out <- pecotmr:::.applySanityChecks(df) - expect_equal(out$df$chrom, c("1", "X", "Y", "MT")) + expect_equal(out$df$chrom, c("chr1", "chrX", "chrY", "chrM")) expect_equal(out$audit$nonstandardChrDropped, 1L) }) @@ -3843,55 +3567,67 @@ test_that("summaryStatsQc: surfaces the sanity audit, honours the knobs", { ldReference = .ssQ_makeHandle() ) res <- summaryStatsQc(ss) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$sanityChecks$zeroEffectDropped, 2L) # Disable the knob: zero-effect rows should remain. res2 <- summaryStatsQc( ss, sumstatsCleaningParam = SumstatsCleaningParam(dropZeroEffect = FALSE) ) - ea2 <- qcInfo(res2)$entryAudit[[1L]] + ea2 <- res2$qcAudit[[1L]] expect_null(ea2$sanityChecks$zeroEffectDropped) }) +# =========================================================================== +# .applySkipRegion +# =========================================================================== + +.ssh_smallDf <- function() { + data.frame( + chrom = c("chr1", "chr1", "chr2"), + pos = c(100L, 200L, 100L), + SNP = c("rs1", "rs2", "rs3"), + Z = c(1, 2, 3), + stringsAsFactors = FALSE + ) +} + test_that(".applySkipRegion: NULL / empty skipRegion is a no-op", { df <- .ssh_smallDf() expect_identical(pecotmr:::.applySkipRegion(df, NULL), df) - expect_identical(pecotmr:::.applySkipRegion(df, character()), df) -}) - -test_that(".applySkipRegion: drops variants in a single character region", { - df <- .ssh_smallDf() - out <- pecotmr:::.applySkipRegion(df, "1:50-150") - expect_equal(out$SNP, c("rs2", "rs3")) + expect_identical( + pecotmr:::.applySkipRegion(df, GenomicRanges::GRanges()), + df + ) }) -test_that(".applySkipRegion: handles multiple regions and chr-prefixed input", { +test_that(".applySkipRegion: handles multiple regions", { df <- .ssh_smallDf() - out <- pecotmr:::.applySkipRegion(df, c("chr1:50-250", "chr2:50-150")) + out <- pecotmr:::.applySkipRegion( + df, + GenomicRanges::GRanges(c("chr1:50-250", "chr2:50-150")) + ) expect_equal(nrow(out), 0L) }) test_that(".applySkipRegion: accepts a GRanges of skip regions", { df <- .ssh_smallDf() + # A window spelled "1" is read as chr1, as every range argument is. gr <- GenomicRanges::GRanges("1", IRanges::IRanges(start = 50, end = 150)) out <- pecotmr:::.applySkipRegion(df, gr) expect_equal(out$SNP, c("rs2", "rs3")) }) -test_that(".applySkipRegion: rejects malformed character entries", { +test_that(".applySkipRegion: refuses anything but a GRanges", { df <- .ssh_smallDf() + # A window given in R is a GRanges; a string is refused, not read. expect_error( - pecotmr:::.applySkipRegion(df, "garbage"), - "must be 'chr:start-end'" + pecotmr:::.applySkipRegion(df, "1:50-150"), + "`skipRegion` must be a GRanges \\(got character\\)" ) -}) - -test_that(".applySkipRegion: rejects non-character non-GRanges input", { - df <- .ssh_smallDf() expect_error( pecotmr:::.applySkipRegion(df, 42L), - "must be a character vector" + "`skipRegion` must be a GRanges" ) }) @@ -4116,7 +3852,7 @@ test_that("fine-mapping keeps onMissing='error' for an absent variant", { "chr1:200:G:A", "chr1:300:C:T" ), - CHR = rep("1", 4L), + CHR = rep("chr1", 4L), BP = c(100L, 200L, 200L, 300L), A1 = c("G", "G", "A", "T"), A2 = c("A", "A", "G", "C"), @@ -4329,30 +4065,28 @@ test_that(".applyEntryScreen: bf / logBf screens use the SER lbf_variable", { }) test_that("summaryStatsQc: absZ / bf / logBf screens skip a no-signal entry", { - mk <- function() { - gr <- .ssQ_makeEntryGr() - S4Vectors::mcols(gr)$Z <- rep(0.1, length(gr)) - GwasSumStats( - studyName = "g1", - entry = list(gr), - genome = "hg19", - ldReference = .ssQ_makeHandle() - ) - } - for (arg in list( - list(signalScreenParam = SignalScreenParam(absZ = 5)), - list(signalScreenParam = SignalScreenParam(bf = 100)), - list(signalScreenParam = SignalScreenParam(logBf = 5)) - )) { - res <- exec( - summaryStatsQc, - mk(), - !!!arg, + gr <- .ssQ_makeEntryGr() + S4Vectors::mcols(gr)$Z <- rep(0.1, length(gr)) + ss <- GwasSumStats( + studyName = "g1", + entry = list(gr), + genome = "hg19", + ldReference = .ssQ_makeHandle() + ) + screens <- list( + absZ = SignalScreenParam(absZ = 5), + bf = SignalScreenParam(bf = 100), + logBf = SignalScreenParam(logBf = 5) + ) + for (metric in names(screens)) { + res <- summaryStatsQc( + ss, + signalScreenParam = screens[[metric]], sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - ea <- qcInfo(res)$entryAudit[[1L]] - expect_true(isTRUE(ea$pipScreenSkipped)) - expect_equal(length(res[[1L]]), 0L) + ea <- res$qcAudit[[1L]] + expect_true(isTRUE(ea$pipScreenSkipped), info = metric) + expect_equal(length(res[[1L]]), 0L, info = metric) } }) @@ -4372,7 +4106,7 @@ test_that("summaryStatsQc: absZ screen keeps a strong marginal Z", { signalScreenParam = SignalScreenParam(absZ = 5), sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_false(isTRUE(ea$pipScreenSkipped)) expect_gt(length(res[[1L]]), 0L) }) @@ -4446,53 +4180,42 @@ generateDentistSingleWindowData <- function( # dentist: basic tests # =========================================================================== -test_that("dentist output has exactly N rows for N input variants", { - data <- generateDentistData(nSnps = 100) - expect_warning( - res <- dentist(data$sumstat, R = data$ldMat, nSample = data$nSample) - ) - expect_equal(nrow(res), 100) -}) - -test_that("dentist output has exactly N rows with correctChenEtAlBug = FALSE", { +test_that("dentist returns one row per variant under each DentistParam", { data <- generateDentistData(nSnps = 100) - expect_warning( - res <- dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - dentistParam = DentistParam(correctChenEtAlBug = FALSE) + params <- list( + default = DentistParam(), + correctChenEtAlBug = DentistParam(correctChenEtAlBug = FALSE), + gcControl = DentistParam(gcControl = TRUE) + ) + for (nm in names(params)) { + expect_warning( + res <- dentist( + data$sumstat, + R = data$ldMat, + nSample = data$nSample, + dentistParam = params[[nm]] + ), + info = nm ) - ) - expect_equal(nrow(res), 100) -}) - -test_that("dentist stops when missing position", { - data <- generateDentistData() - colnames(data$sumstat) <- c("something", "z") - expect_error( - dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - dentistParam = DentistParam(correctChenEtAlBug = FALSE) - ), - regexp = "missing either.*pos.*or.*z" - ) + expect_equal(nrow(res), 100, info = nm) + } }) -test_that("dentist stops when missing zscore", { +test_that("dentist stops when the position or z column is missing", { data <- generateDentistData() - colnames(data$sumstat) <- c("position", "something") - expect_error( - dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - dentistParam = DentistParam(correctChenEtAlBug = FALSE) - ), - regexp = "missing either.*pos.*or.*z" - ) + for (cols in list(c("something", "z"), c("position", "something"))) { + sumstat <- `colnames<-`(data$sumstat, cols) + expect_error( + dentist( + sumstat, + R = data$ldMat, + nSample = data$nSample, + dentistParam = DentistParam(correctChenEtAlBug = FALSE) + ), + regexp = "missing either.*pos.*or.*z", + info = str_flatten(cols, " / ") + ) + } }) test_that("dentist accepts 'position' and 'zscore' column names", { @@ -4556,6 +4279,7 @@ test_that("dentistSingleWindow from genotypes matches DENTIST on their LD", { d <- .dentistFactorData() viaX <- suppressWarnings(dentistSingleWindow(d$z, X = d$X)) viaR <- suppressWarnings(dentistSingleWindow(d$z, R = d$R, nSample = d$n)) + expect_equal(nrow(viaX), length(d$z)) expect_equal(viaX, viaR, tolerance = 1e-8) }) @@ -4595,49 +4319,17 @@ test_that("the duplicate scan reads a factor as it reads the LD", { # dentistSingleWindow # =========================================================================== -test_that("dentistSingleWindow returns exactly N rows for N input z-scores", { - data <- generateDentistSingleWindowData() - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample - ) - ) - expect_equal(nrow(res), 100) -}) - -test_that("dentistSingleWindow warns when < 2000 variants", { - data <- generateDentistSingleWindowData() - expect_warning(dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample - )) -}) - -test_that("dentistSingleWindow stops on a zscore/LD dimension mismatch", { - data <- generateDentistSingleWindowData() - expect_warning(expect_error( - dentistSingleWindow( - generateDentistSingleWindowData()$z_scores, - R = generateDentistSingleWindowData(nSnps = 80)$ldMat, - nSample = data$nSample - ), - regexp = "ldMat must be a square matrix" - )) -}) - -test_that("dentistSingleWindow output columns are correct", { +test_that("dentistSingleWindow returns one row per z-score under each option", { + # Every option set keeps the input z, reports the documented columns and + # an outlier_stat of (z - imputed)^2 / (1 - rsq); fewer than 2000 + # variants also draw DENTIST's size warning. data <- generateDentistSingleWindowData() - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample - ) + options <- list( + default = list(), + correctChenEtAlBug = list(correctChenEtAlBug = FALSE), + gcControl = list(gcControl = TRUE) ) - expected_cols <- c( + expectedCols <- c( "original_z", "imputed_z", "iter_to_correct", @@ -4646,108 +4338,48 @@ test_that("dentistSingleWindow output columns are correct", { "outlier_stat", "outlier" ) - expect_true(all(expected_cols %in% colnames(res))) -}) - -test_that("dentistSingleWindow original_z matches input z-scores", { - data <- generateDentistSingleWindowData() - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample + for (nm in names(options)) { + expect_warning( + res <- exec( + dentistSingleWindow, + data$z_scores, + R = data$ldMat, + nSample = data$nSample, + !!!options[[nm]] + ), + "below 2000", + info = nm ) - ) - expect_equal(res$original_z, data$z_scores) -}) - -test_that("dentistSingleWindow with X matrix input returns exactly N rows", { - set.seed(42) - nSnps <- 80 - n_samples <- 100 - X <- matrix( - rbinom(nSnps * n_samples, 2, 0.3), - nrow = n_samples, - ncol = nSnps - ) - z_scores <- rnorm(nSnps) - expect_warning(res <- dentistSingleWindow(z_scores, X = X)) - expect_equal(nrow(res), nSnps) -}) - -test_that("dentistSingleWindow correctChenEtAlBug = FALSE returns N rows", { - data <- generateDentistSingleWindowData() - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample, - correctChenEtAlBug = FALSE + expect_equal(nrow(res), 100, info = nm) + expect_true(all(expectedCols %in% colnames(res)), info = nm) + expect_type(res$outlier, "logical") + expect_equal(res$original_z, data$z_scores, info = nm) + expect_equal( + res$outlier_stat, + (res$original_z - res$imputed_z)^2 / pmax(1 - res$rsq, 1e-8), + tolerance = 1e-10, + info = nm ) - ) - expect_equal(nrow(res), 100) - expect_true(all(c("original_z", "imputed_z", "outlier") %in% colnames(res))) + } }) -test_that("dentistSingleWindow with gcControl = TRUE returns N rows", { +test_that("dentistSingleWindow stops on a zscore/LD dimension mismatch", { data <- generateDentistSingleWindowData() - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample, - gcControl = TRUE - ) - ) - expect_equal(nrow(res), 100) - expect_true(all(c("original_z", "imputed_z", "outlier") %in% colnames(res))) -}) - -test_that("dentist with gcControl = TRUE returns N rows", { - data <- generateDentistData(nSnps = 100) - expect_warning( - res <- dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - dentistParam = DentistParam(gcControl = TRUE) - ) - ) - expect_equal(nrow(res), 100) -}) - -test_that("dentistSingleWindow dedup path with message for duplicates", { - set.seed(42) - nSnps <- 80 - n_samples <- 100 - cor_matrix <- matrix(0, nrow = nSnps, ncol = nSnps) - for (i in seq_len(nSnps - 1)) { - for (j in (i + 1):nSnps) { - cor_matrix[i, j] <- runif(1, 0.2, 0.8) - cor_matrix[j, i] <- cor_matrix[i, j] - } - } - diag(cor_matrix) <- 1 - ld_matrix <- cov2cor(make.positive.definite(cor_matrix)) - z_scores <- mvrnorm(n = 1, mu = rep(0, nSnps), Sigma = ld_matrix) - # Use a very low threshold to trigger dedup logic - expect_warning( - res <- dentistSingleWindow( - z_scores, - R = ld_matrix, - nSample = n_samples, - duprThreshold = 0.5 - ) - ) - expect_equal(nrow(res), nSnps) - expect_true("is_duplicate" %in% colnames(res)) + expect_warning(expect_error( + dentistSingleWindow( + generateDentistSingleWindowData()$z_scores, + R = generateDentistSingleWindowData(nSnps = 80)$ldMat, + nSample = data$nSample + ), + regexp = "ldMat must be a square matrix" + )) }) # =========================================================================== -# add_dups_back_dentist +# addDupsBackDentist # =========================================================================== -test_that("add_dups_back_dentist works", { +test_that("addDupsBackDentist works", { zScore <- c(1.2, 2.3, 2.4, 1.4, 5.6) dentist_output <- data.frame( original_z = c(1.2, 2.3, 5.6), @@ -4777,40 +4409,11 @@ test_that("add_dups_back_dentist works", { expect_equal(res$is_duplicate, c(FALSE, FALSE, TRUE, TRUE, FALSE)) }) -test_that("add_dups_back_dentist stops when nrow mismatch", { - z_scores <- rep(0, 5) - dentist_output <- list( - original_z = c(1, 2, 3, 4, 5), - imputed_z = c(1, 2, 3, 4, 5), - iter_to_correct = c(1, 2, 3, 4, 5), - rsq = c(1, 2, 3, 4, 5), - z_diff = c(1, 2, 3, 4, 5) - ) - find_dup_output <- list( - dupBearer = c(-1, -1, -1, -1, -1, -1), - sign = c(1, 2, 3, 4, 5, 6) - ) - expect_error(pecotmr:::addDupsBackDentist( - z_scores, - dentist_output, - find_dup_output - )) -}) - # =========================================================================== -# segment_by_dist +# segmentByDist # =========================================================================== -test_that("segment_by_dist works", { - res <- pecotmr:::segmentByDist( - seq(2000000, 5000000, 100000), - maxDist = 2000000, - minDim = 10 - ) - expect_true(nrow(res) >= 1) -}) - -test_that("segment_by_dist fill regions cover all input positions", { +test_that("segmentByDist fill regions cover all input positions", { # Verify that fill regions cover every SNP index exactly once pos <- seq(1000000, 5000000, length.out = 200) res <- pecotmr:::segmentByDist(pos, maxDist = 2000000, minDim = 10) @@ -4823,11 +4426,11 @@ test_that("segment_by_dist fill regions cover all input positions", { expect_equal(sort(unique(covered)), seq_along(pos)) }) -test_that("segment_by_dist errors on empty positions", { +test_that("segmentByDist errors on empty positions", { expect_error(pecotmr:::segmentByDist(integer(0)), "No positions") }) -test_that("segment_by_dist verbose mode prints intervals", { +test_that("segmentByDist verbose mode prints intervals", { pos <- seq(1000000, 5000000, length.out = 300) expect_message( pecotmr:::segmentByDist( @@ -4841,34 +4444,24 @@ test_that("segment_by_dist verbose mode prints intervals", { }) # =========================================================================== -# detect_gaps +# detectGaps # =========================================================================== -test_that("detect_gaps finds no internal gaps for contiguous positions", { +test_that("detectGaps finds no internal gaps for contiguous positions", { pos <- seq(1000, by = 100, length.out = 50) gaps <- pecotmr:::detectGaps(pos, gapThreshold = 500) # Only start and end sentinel expect_equal(gaps, c(1L, 51L)) }) -test_that("detect_gaps finds a centromeric gap", { - pos <- c( - seq(1000, by = 100, length.out = 50), - seq(2000000, by = 100, length.out = 50) - ) - gaps <- pecotmr:::detectGaps(pos, gapThreshold = 1e6) - expect_equal(length(gaps), 3) # start, gap, end - expect_equal(gaps, c(1L, 51L, 101L)) -}) - -test_that("detect_gaps finds multiple gaps", { +test_that("detectGaps finds multiple gaps", { pos <- c(1000, 2000, 5000000, 6000000, 12000000) gaps <- pecotmr:::detectGaps(pos, gapThreshold = 1e6) # Gaps at positions 3 and 5 (diffs > 1e6 at indices 2 and 4) expect_equal(gaps, c(1L, 3L, 5L, 6L)) }) -test_that("detect_gaps verbose branch prints messages", { +test_that("detectGaps verbose branch prints messages", { pos <- c(1000, 2000, 5000000, 6000000) expect_message( pecotmr:::detectGaps(pos, gapThreshold = 1e6, verbose = TRUE), @@ -4877,27 +4470,22 @@ test_that("detect_gaps verbose branch prints messages", { }) # =========================================================================== -# segment_by_count +# segmentByCount # =========================================================================== -test_that("segment_by_count produces valid windows", { - pos <- seq(1000000, by = 1000, length.out = 500) +test_that("segmentByCount tiles one block with valid, covering windows", { + # 200 variants with maxCount = 100 make a few overlapping windows. + pos <- seq(1000000, by = 1000, length.out = 200) res <- pecotmr:::segmentByCount(pos, maxCount = 100) - expect_true(nrow(res) >= 1) - # All window starts should be >= 1 + expect_true(nrow(res) >= 2) + expect_true(nrow(res) <= 5) + # Window indices stay in range (end indices are 1-based exclusive) and + # each fill region sits inside its window. expect_true(all(res$windowStartIdx >= 1)) - # All window ends should be <= length(pos) + 1 expect_true(all(res$windowEndIdx <= length(pos) + 1)) - # Fill regions should be within windows - for (k in seq_len(nrow(res))) { - expect_true(res$fillStartIdx[k] >= res$windowStartIdx[k]) - expect_true(res$fillEndIdx[k] <= res$windowEndIdx[k]) - } -}) - -test_that("segment_by_count fill regions cover all positions", { - pos <- seq(1000000, by = 1000, length.out = 500) - res <- pecotmr:::segmentByCount(pos, maxCount = 100) + expect_true(all(res$fillStartIdx >= res$windowStartIdx)) + expect_true(all(res$fillEndIdx <= res$windowEndIdx)) + # The fill regions tile every position. covered <- integer(0) for (k in seq_len(nrow(res))) { covered <- c(covered, res$fillStartIdx[k]:(res$fillEndIdx[k] - 1L)) @@ -4905,7 +4493,7 @@ test_that("segment_by_count fill regions cover all positions", { expect_equal(sort(unique(covered)), seq_along(pos)) }) -test_that("segment_by_count handles centromeric gap", { +test_that("segmentByCount handles centromeric gap", { # Create two blocks separated by a large gap pos <- c( seq(1000000, by = 1000, length.out = 200), @@ -4922,8 +4510,8 @@ test_that("segment_by_count handles centromeric gap", { expect_equal(sort(unique(covered)), seq_along(pos)) }) -test_that("segment_by_count skips blocks smaller than half max_count", { - # Block of 20 variants with max_count=100 (half=50): too small, should be skipped +test_that("segmentByCount skips blocks smaller than half maxCount", { + # 20 variants with maxCount = 100 (half = 50): too small, so skipped. pos <- seq(1000000, by = 1000, length.out = 20) expect_error( pecotmr:::segmentByCount(pos, maxCount = 100), @@ -4931,8 +4519,8 @@ test_that("segment_by_count skips blocks smaller than half max_count", { ) }) -test_that("segment_by_count creates single window for small blocks", { - # Block of 60 variants with max_count=100: creates one window (60 >= half=50) +test_that("segmentByCount creates single window for small blocks", { + # 60 variants with maxCount = 100 make one window (60 >= half = 50). pos <- seq(1000000, by = 1000, length.out = 60) res <- pecotmr:::segmentByCount(pos, maxCount = 100) expect_equal(nrow(res), 1) @@ -4940,22 +4528,14 @@ test_that("segment_by_count creates single window for small blocks", { expect_equal(res$windowEndIdx[1], 61) }) -test_that("segment_by_count single block creates correct number of windows", { - # 200 variants with maxCount = 100 should create ~3 windows - pos <- seq(1000000, by = 1000, length.out = 200) - res <- pecotmr:::segmentByCount(pos, maxCount = 100) - expect_true(nrow(res) >= 2) - expect_true(nrow(res) <= 5) -}) - -test_that("segment_by_count errors on empty positions", { +test_that("segmentByCount errors on empty positions", { expect_error( pecotmr:::segmentByCount(integer(0), maxCount = 100), "No positions" ) }) -test_that("segment_by_count verbose mode prints intervals", { +test_that("segmentByCount verbose mode prints intervals", { pos <- seq(1000000, by = 1000, length.out = 300) expect_message( pecotmr:::segmentByCount(pos, maxCount = 100, verbose = TRUE), @@ -4964,12 +4544,15 @@ test_that("segment_by_count verbose mode prints intervals", { }) # =========================================================================== -# merge_windows +# mergeWindows # =========================================================================== -test_that("merge_windows returns exactly N rows", { +test_that("mergeWindows returns exactly N rows", { + # 300 variants over 2 kb with maxDist = 1000 make four overlapping + # windows; the LD build is cubic in the variant count, so no more. + nSnps <- 300L data <- generateDentistData( - nSnps = 1000, + nSnps = nSnps, sample_size = 1000, start_pos = 0, end_pos = 2000 @@ -4997,23 +4580,26 @@ test_that("merge_windows returns exactly N rows", { nIter = 10, gPvalueThreshold = 0.05, duprThreshold = 0.99, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), correctChenEtAlBug = TRUE ) } }) res <- pecotmr:::mergeWindows(dentist_result_by_window, window_divided_res) - expect_equal(nrow(res), 1000) + expect_equal(nrow(res), nSnps) }) -test_that("merge_windows stops with window and imputed mismatch", { - expect_error(pecotmr:::mergeWindows( - rep(0, 5), - data.frame(windowStartIdx = rep(0, 2), windowEndIdx = rep(0, 2)) - )) +test_that("mergeWindows stops with window and imputed mismatch", { + expect_error( + pecotmr:::mergeWindows( + rep(0, 5), + data.frame(windowStartIdx = rep(0, 2), windowEndIdx = rep(0, 2)) + ), + "Different number of windows and imputed results" + ) }) -test_that("merge_windows correctly indexes and merges windows", { +test_that("mergeWindows correctly indexes and merges windows", { # Create two fake windows window1 <- data.frame( original_z = c(1.0, 2.0, 3.0), @@ -5051,12 +4637,15 @@ test_that("merge_windows correctly indexes and merges windows", { # =========================================================================== test_that("dentist windowed output has exactly N rows for large input", { - # Generate data large enough to trigger windowed mode (> min_dim) + # 300 variants over 5 Mb with windowSize = 2e6 make five overlapping + # windows of more than minDim variants each; the LD build is cubic in + # the variant count, so no more. + nSnps <- 300L data <- generateDentistData( seed = 123, - nSnps = 1000, + nSnps = nSnps, sample_size = 1000, - n_outliers = 50, + n_outliers = 15, start_pos = 0, end_pos = 5000000 ) @@ -5069,21 +4658,7 @@ test_that("dentist windowed output has exactly N rows for large input", { windowSize = 2000000 ) }) - expect_equal(nrow(res), 1000) -}) - -test_that("dentist outlier_stat formula is correct: (z-imputed)^2/(1-rsq)", { - data <- generateDentistSingleWindowData(seed = 55, nSnps = 100) - expect_warning( - res <- dentistSingleWindow( - data$z_scores, - R = data$ldMat, - nSample = data$nSample - ) - ) - expected_stat <- (res$original_z - res$imputed_z)^2 / - pmax(1 - res$rsq, 1e-8) - expect_equal(res$outlier_stat, expected_stat, tolerance = 1e-10) + expect_equal(nrow(res), nSnps) }) # =========================================================================== @@ -5112,113 +4687,24 @@ test_that("dentist with window_mode='count' returns exactly N rows", { }) # =========================================================================== -# Equivalence tests: both windowing methods -# =========================================================================== - -test_that("segment_by_dist and segment_by_count agree on even spacing", { - n <- 200 - spacing <- 10000 # 10kb between each variant - pos <- seq(1000000, by = spacing, length.out = n) - window_count <- 50 # variants per window in count mode - window_dist <- window_count * spacing # equivalent distance - - res_dist <- pecotmr:::segmentByDist(pos, maxDist = window_dist, minDim = 10) - res_count <- pecotmr:::segmentByCount( - pos, - maxCount = window_count, - gapDist = 1e6 - ) - - # Both should cover all positions - covered_dist <- integer(0) - for (k in seq_len(nrow(res_dist))) { - covered_dist <- c( - covered_dist, - res_dist$fillStartIdx[k]:(res_dist$fillEndIdx[k] - 1L) - ) - } - covered_count <- integer(0) - for (k in seq_len(nrow(res_count))) { - covered_count <- c( - covered_count, - res_count$fillStartIdx[k]:(res_count$fillEndIdx[k] - 1L) - ) - } - expect_equal(sort(unique(covered_dist)), seq_len(n)) - expect_equal(sort(unique(covered_count)), seq_len(n)) -}) - -test_that("both windowing modes produce same dentist results on uniform data", { - data <- generateDentistData( - seed = 555, - nSnps = 500, - sample_size = 500, - n_outliers = 25, - start_pos = 0, - end_pos = 5000000 - ) - suppressWarnings({ - res_dist <- dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - windowMode = "distance", - minDim = 100, - windowSize = 2000000 - ) - res_count <- dentist( - data$sumstat, - R = data$ldMat, - nSample = data$nSample, - windowMode = "count", - minDim = 100 - ) - }) - # Both should return exactly N rows - expect_equal(nrow(res_dist), 500) - expect_equal(nrow(res_count), 500) -}) - -# =========================================================================== -# resolve_LD_input (internal) +# resolveLdInput (internal) # =========================================================================== -test_that("resolve_LD_input errors when neither R nor X provided", { - expect_error( - pecotmr:::resolveLdInput(R = NULL, X = NULL), - "Either R.*or X.*must be provided" - ) -}) - -test_that("resolve_LD_input errors when both R and X provided", { - R <- diag(3) - X <- matrix(1:9, nrow = 3) - expect_error( - pecotmr:::resolveLdInput(R = R, X = X), - "Provide either R or X, not both" - ) -}) - -test_that("resolve_LD_input errors on R without nSample when required", { - R <- diag(3) - expect_error( - pecotmr:::resolveLdInput(R = R, nSample = NULL, needNSample = TRUE), - "nSample is required" - ) -}) - -test_that("resolve_LD_input returns nSample = NULL when not needed", { +test_that("resolveLdInput passes R through, with or without its nSample", { R <- diag(3) + result <- pecotmr:::resolveLdInput(R = R, needNSample = FALSE) + expect_equal(result$R, R) + expect_null(result$nSample) result <- pecotmr:::resolveLdInput( R = R, - nSample = NULL, - needNSample = FALSE + nSample = 100L, + needNSample = TRUE ) - expect_null(result$nSample) expect_equal(result$R, R) + expect_equal(result$nSample, 100L) }) -test_that("resolve_LD_input infers nSample from X", { +test_that("resolveLdInput computes the LD and nSample from genotypes", { set.seed(42) n <- 50 p <- 5 @@ -5226,10 +4712,12 @@ test_that("resolve_LD_input infers nSample from X", { result <- pecotmr:::resolveLdInput(X = X, needNSample = TRUE) expect_equal(result$nSample, n) expect_true(is.matrix(result$R)) - expect_equal(nrow(result$R), p) + expect_equal(dim(result$R), c(p, p)) + expect_true(isSymmetric(result$R)) + expect_equal(diag(result$R), rep(1, p), tolerance = 1e-6) }) -test_that("resolve_LD_input converts non-matrix X to matrix", { +test_that("resolveLdInput converts a non-matrix X to a matrix", { set.seed(42) X_df <- data.frame(a = rbinom(30, 2, 0.3), b = rbinom(30, 2, 0.3)) result <- pecotmr:::resolveLdInput(X = X_df, needNSample = FALSE) @@ -5237,18 +4725,36 @@ test_that("resolve_LD_input converts non-matrix X to matrix", { expect_equal(result$nSample, 30) }) -test_that("resolve_LD_input uses explicit nSample when X provided", { +test_that("resolveLdInput keeps an explicit nSample given with X", { set.seed(42) X <- matrix(rbinom(100, 2, 0.3), nrow = 20, ncol = 5) result <- pecotmr:::resolveLdInput(X = X, nSample = 999, needNSample = TRUE) expect_equal(result$nSample, 999) }) +test_that("resolveLdInput needs exactly one of R and X", { + expect_error( + pecotmr:::resolveLdInput(), + "Either R.*or X.*must be provided" + ) + expect_error( + pecotmr:::resolveLdInput(R = diag(3), X = matrix(1:9, nrow = 3)), + "Provide either R or X, not both" + ) +}) + +test_that("resolveLdInput needs nSample with R when one is required", { + expect_error( + pecotmr:::resolveLdInput(R = diag(3), needNSample = TRUE), + "nSample is required" + ) +}) + # =========================================================================== -# build_segment_result (internal) +# buildSegmentResult (internal) # =========================================================================== -test_that("build_segment_result caps end indices and verbose prints", { +test_that("buildSegmentResult caps end indices and verbose prints", { expect_message( result <- pecotmr:::buildSegmentResult( startList = c(1L), @@ -5264,7 +4770,7 @@ test_that("build_segment_result caps end indices and verbose prints", { expect_equal(result$fillEndIdx[1], 101) }) -test_that("build_segment_result errors on empty startList", { +test_that("buildSegmentResult errors on empty startList", { expect_error( pecotmr:::buildSegmentResult( startList = integer(0), @@ -5278,10 +4784,10 @@ test_that("build_segment_result errors on empty startList", { }) # =========================================================================== -# sliding_window_loop (iteration limit) +# slidingWindowLoop (iteration limit) # =========================================================================== -test_that("sliding_window_loop errors on infinite loop", { +test_that("slidingWindowLoop errors on infinite loop", { allGaps <- c(1L, 1001L) expect_error( pecotmr:::slidingWindowLoop( @@ -5360,6 +4866,10 @@ test_that("autoDecision assigns SER for single CS", { expect_equal(result$method, "SER") }) +# =========================================================================== +# summaryStatsQc: study-level case/control counts +# =========================================================================== + test_that("summaryStatsQc: preserves nCase/nControl columns through QC", { gr <- .ssQ_makeEntryGr(paste0("rs", 1:4), c(100L, 200L, 300L, 400L)) ss <- GwasSumStats( @@ -5448,246 +4958,46 @@ test_that("mergeVariantInfo (GRanges): converts inputs and detects flips", { } g1 <- ssqcMakeGr( c(1, 1, 2), - c(100, 200, 300), - c("A", "C", "G"), - c("G", "T", "A") - ) - g2 <- ssqcMakeGr( - c(1, 1, 3), - c(100, 200, 400), - c("A", "T", "C"), - c("G", "C", "A") - ) - out <- mergeVariantInfo(g1, g2, all = TRUE) - expect_s3_class(out, "data.frame") - expect_equal(nrow(out), 4L) - flipped <- out[out$chrom == "chr1" & out$pos == 200, ] - expect_equal(flipped$alt, "C") - expect_equal(flipped$ref, "T") -}) - -test_that("mergeVariantInfo does not warn on length-mismatch recycling", { - # Regression guard: the flip vector must be full-length so `hasMatch & ...` - # never recycles a subset-length comparison. - v1 <- data.frame( - chrom = c("1", "1", "2"), - pos = c(100, 200, 300), - alt = c("A", "C", "G"), - ref = c("G", "T", "A"), - stringsAsFactors = FALSE - ) - v2 <- data.frame( - chrom = c("1", "1", "3"), - pos = c(100, 200, 400), - alt = c("A", "T", "C"), - ref = c("G", "C", "A"), - stringsAsFactors = FALSE - ) - expect_no_warning(out <- mergeVariantInfo(v1, v2, all = TRUE)) - # Behaviour is unchanged: the flipped row collapses onto v1's orientation. - flipped <- out[out$chrom == "1" & out$pos == 200, ] - expect_equal(flipped$alt, "C") - expect_equal(flipped$ref, "T") -}) - -# =========================================================================== -# harmonizeAlleles uncovered branches -# =========================================================================== - -test_that("harmonizeAlleles: accepts a bare variant-id vector as target", { - res <- pecotmr:::harmonizeAlleles( - c("chr1:100:A:G", "chr1:200:C:T"), - c("chr1:100:A:G", "chr1:200:C:T"), - matchMinProp = 0 - ) - expect_equal(nrow(res$harmonizedData), 2L) -}) - -test_that("harmonizeAlleles: strips a conflicting variant_id from target", { - target <- data.frame( - chrom = c(1, 1), - pos = c(100, 200), - A2 = c("A", "C"), - A1 = c("G", "T"), - variant_id = c("old1", "old2"), - z = c(1, 2), - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = c(1, 1), - pos = c(100, 200), - A2 = c("A", "C"), - A1 = c("G", "T"), - stringsAsFactors = FALSE - ) - res <- pecotmr:::harmonizeAlleles( - target, - ref, - colToFlip = "z", - matchMinProp = 0 - ) - expect_equal(nrow(res$harmonizedData), 2L) - # The input variant_id was stripped; the returned id is rebuilt from QC'd alleles. - expect_false(any(c("old1", "old2") %in% res$harmonizedData$variant_id)) -}) - -test_that("harmonizeAlleles: errors when colToFlip column is absent", { - target <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - z = 1, - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - stringsAsFactors = FALSE - ) - expect_error( - pecotmr:::harmonizeAlleles( - target, - ref, - colToFlip = "missingCol", - matchMinProp = 0 - ), - "not found in targetData" - ) -}) - -test_that("harmonizeAlleles: errors when colToComplement column is absent", { - target <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - z = 1, - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - stringsAsFactors = FALSE - ) - expect_error( - pecotmr:::harmonizeAlleles( - target, - ref, - colToComplement = "missingAf", - matchMinProp = 0 - ), - "not found in targetData" - ) -}) - -test_that("harmonizeAlleles: complements colToComplement on a swap", { - # pos 100 exact; pos 200 allele-swapped -> sign_flip => z negated, af -> 1-af. - target <- data.frame( - chrom = c(1, 1), - pos = c(100, 200), - A2 = c("A", "A"), - A1 = c("G", "G"), - z = c(1, 2), - af = c(0.3, 0.4), - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = c(1, 1), - pos = c(100, 200), - A2 = c("A", "G"), - A1 = c("G", "A"), - stringsAsFactors = FALSE - ) - res <- pecotmr:::harmonizeAlleles( - target, - ref, - colToFlip = "z", - colToComplement = "af", - matchMinProp = 0 - ) - hd <- res$harmonizedData - row200 <- hd[hd$pos == 200, ] - expect_equal(row200$af, 0.6) # 1 - 0.4 - expect_equal(row200$z, -2) # sign-flipped -}) - -test_that("harmonizeAlleles: removeDups = TRUE warns and drops dups", { - target <- data.frame( - chrom = c(1, 1), - pos = c(100, 100), - A2 = c("A", "A"), - A1 = c("G", "G"), - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - stringsAsFactors = FALSE - ) - expect_warning( - res <- pecotmr:::harmonizeAlleles( - target, - ref, - removeDups = TRUE, - matchMinProp = 0 - ), - "Removed 1 duplicate" - ) - expect_equal(nrow(res$harmonizedData), 1L) -}) - -test_that("harmonizeAlleles: errors when duplicate IDs remain", { - target <- data.frame( - chrom = c(1, 1), - pos = c(100, 100), - A2 = c("A", "A"), - A1 = c("G", "G"), - stringsAsFactors = FALSE - ) - ref <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", - stringsAsFactors = FALSE + c(100, 200, 300), + c("A", "C", "G"), + c("G", "T", "A") ) - expect_error( - pecotmr:::harmonizeAlleles( - target, - ref, - removeDups = FALSE, - matchMinProp = 0 - ), - "Duplicated variant IDs remain" + g2 <- ssqcMakeGr( + c(1, 1, 3), + c(100, 200, 400), + c("A", "T", "C"), + c("G", "C", "A") ) + out <- mergeVariantInfo(g1, g2, all = TRUE) + expect_s3_class(out, "data.frame") + expect_equal(nrow(out), 4L) + flipped <- out[out$chrom == "chr1" & out$pos == 200, ] + expect_equal(flipped$alt, "C") + expect_equal(flipped$ref, "T") }) -test_that("harmonizeAlleles: errors when too few match (matchMinProp)", { - target <- data.frame( - chrom = 1, - pos = 100, - A2 = "A", - A1 = "G", +test_that("mergeVariantInfo does not warn on length-mismatch recycling", { + # Regression guard: the flip vector must be full-length so `hasMatch & ...` + # never recycles a subset-length comparison. + v1 <- data.frame( + chrom = c("1", "1", "2"), + pos = c(100, 200, 300), + alt = c("A", "C", "G"), + ref = c("G", "T", "A"), stringsAsFactors = FALSE ) - ref <- data.frame( - chrom = rep(1, 10), - pos = seq(100, 1000, 100), - A2 = rep("A", 10), - A1 = rep("G", 10), + v2 <- data.frame( + chrom = c("1", "1", "3"), + pos = c(100, 200, 400), + alt = c("A", "T", "C"), + ref = c("G", "C", "A"), stringsAsFactors = FALSE ) - expect_error( - pecotmr:::harmonizeAlleles(target, ref, matchMinProp = 0.9), - "Not enough variants" - ) + expect_no_warning(out <- mergeVariantInfo(v1, v2, all = TRUE)) + # Behaviour is unchanged: the flipped row collapses onto v1's orientation. + flipped <- out[out$chrom == "1" & out$pos == 200, ] + expect_equal(flipped$alt, "C") + expect_equal(flipped$ref, "T") }) # =========================================================================== @@ -5745,23 +5055,53 @@ test_that("slalom coerces a non-matrix X (data.frame) to a matrix", { }) # =========================================================================== -# autoDecision: high-correlation tagging branch is reached +# autoDecision: high-correlation tagging branch # =========================================================================== test_that("autoDecision evaluates the high-corr tag for a non-top CS", { - # A non-top CS with a small p-value forces evaluation of the highCorrCols - # branch (the `..col` accessor errors without data.table; we only need the - # line to be exercised). + # A non-top CS with a small p-value can only be tagged through + # highCorrCols: a 1 in its correlation column tags it, leaving SER. + # cs_corr_1 is each CS's correlation with L1, as extractCsInfo() lays + # it out, so L1's own entry is 1; being the top CS, L1 is never tagged. df <- data.frame( cs_name = c("L1", "L2"), top_z = c(5.0, 3.0), p_value = c(1e-10, 1e-10), + cs_corr_1 = c(1, 1), stringsAsFactors = FALSE ) - expect_error(suppressWarnings(autoDecision( - df, - highCorrCols = c("cs_corr_1") - ))) + tagged <- autoDecision(df, highCorrCols = "cs_corr_1") + expect_equal(tagged$tagged_cs, c(FALSE, TRUE)) + expect_equal(tagged$method, c("SER", "SER")) + # Correlated with L1 short of 1, L2 stays untagged. + df$cs_corr_1 <- c(1, 0.5) + untagged <- autoDecision(df, highCorrCols = "cs_corr_1") + expect_equal(untagged$tagged_cs, c(FALSE, FALSE)) + expect_equal(untagged$method, c("BVSR", "BVSR")) +}) + +test_that("autoDecision never tags a CS by its own correlation column", { + # Every cs_corr_* column passed: L2's diagonal entry (its self- + # correlation, always 1) must not tag it; only its correlation with + # L1 can. + df <- data.frame( + cs_name = c("L1", "L2"), + top_z = c(5.0, 3.0), + p_value = c(1e-10, 1e-10), + cs_corr_1 = c(1, 0.2), + cs_corr_2 = c(0.2, 1), + stringsAsFactors = FALSE + ) + cols <- c("cs_corr_1", "cs_corr_2") + untagged <- autoDecision(df, highCorrCols = cols) + expect_equal(untagged$tagged_cs, c(FALSE, FALSE)) + expect_equal(untagged$method, c("BVSR", "BVSR")) + df$cs_corr_1[2] <- 1 + df$cs_corr_2[1] <- 1 + expect_equal( + autoDecision(df, highCorrCols = cols)$tagged_cs, + c(FALSE, TRUE) + ) }) # =========================================================================== @@ -5948,8 +5288,6 @@ test_that("raissSingleMatrixFromX emits no-known / no-unknown messages", { expect_equal(res_no_unknown$resultNofilter, all_known) }) -# =========================================================================== - # =========================================================================== # .qcRaissMerge: observed-variant AF is preserved through the RAISS merge # =========================================================================== @@ -6006,82 +5344,6 @@ test_that(".qcRaissMerge adds no AF column when the study declared none", { expect_false("AF" %in% colnames(out)) }) -# =========================================================================== -# raiss: multi-LD-block verbose / merge / error branches -# =========================================================================== - -# Build a 2-block LD list whose shared boundary variant is IMPUTED (not known) -# in both blocks, so its raissR2 is a finite value on both sides and the -# boundary-merge R2 comparison branches are exercised. -ssqcOverlapImputedBlocks <- function(seed = 5) { - set.seed(seed) - vid <- sprintf("chr1:%d:A:G", 100L * (1:8)) - pos <- seq(10, 80, by = 10) - ref_panel <- data.frame( - chrom = rep(1, 8), - pos = pos, - variant_id = vid, - A1 = rep("A", 8), - A2 = rep("G", 8), - stringsAsFactors = FALSE - ) - # v4 (the boundary) is left out of the known set so it is imputed in both blocks. - known_idx <- c(1, 2, 3, 5, 6, 7, 8) - known_zscores <- data.frame( - chrom = rep(1, length(known_idx)), - pos = pos[known_idx], - variant_id = vid[known_idx], - A1 = rep("A", length(known_idx)), - A2 = rep("G", length(known_idx)), - z = rnorm(length(known_idx)), - stringsAsFactors = FALSE - ) - mkBlock <- function(ids) { - nb <- length(ids) - m <- matrix(0, nb, nb) - for (a in seq_len(nb)) { - for (b in seq_len(nb)) { - m[a, b] <- if (a == b) 1 else 0.9^abs(a - b) - } - } - rownames(m) <- colnames(m) <- ids - m - } - block1_ids <- vid[1:4] - block2_ids <- vid[4:8] - variantIndices <- rbind( - data.frame( - variant_id = block1_ids, - blockId = 1L, - stringsAsFactors = FALSE - ), - data.frame( - variant_id = block2_ids, - blockId = 2L, - stringsAsFactors = FALSE - ) - ) - blockMetadata <- data.frame( - blockId = c(1L, 2L), - chrom = c(1, 1), - size = c(4L, 5L), - startIdx = c(1L, 4L), - endIdx = c(4L, 8L), - stringsAsFactors = FALSE - ) - ldBlocks <- list( - ldMatrices = list(mkBlock(block1_ids), mkBlock(block2_ids)), - variantIndices = variantIndices, - blockMetadata = blockMetadata, - ldVariants = vid - ) - list( - ref_panel = ref_panel, - known_zscores = known_zscores, - LD_matrix_blocks = ldBlocks - ) -} - # =========================================================================== # raissModel: batch = FALSE with condition-number reporting # =========================================================================== @@ -6115,10 +5377,6 @@ test_that("raissModel flags an inversion the rcond cutoff truncated", { expect_identical(ok$correctInversion, c(TRUE, TRUE)) }) -# =========================================================================== -# krigingOutlierQc: non-square LD stop + variantIds defaulting to rownames -# =========================================================================== - # =========================================================================== # .safeSvd: all singular values below tolerance # =========================================================================== @@ -6251,7 +5509,7 @@ test_that("summaryStatsQc: the N filter emits its message and rollup", { joined <- paste(msgs, collapse = "") expect_match(joined, "MAF/INFO/N filters kept") expect_match(joined, "nCutoff 1") - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$contentFilters$nDropped, 1L) }) @@ -6278,7 +5536,7 @@ test_that("summaryStatsQc: derives BETA/SE from Z+MAF+N, records it", { ss, sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$betaSeFromZ$nDerived, 4L) }) @@ -6295,7 +5553,7 @@ test_that("summaryStatsQc: clamps tiny Z-derived P and audits it", { ss, sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_true(!is.null(ea$sanityChecks$smallPClamped)) expect_gte(ea$sanityChecks$smallPClamped, 1L) }) @@ -6312,7 +5570,7 @@ test_that("summaryStatsQc: early-exits below two pre-harmonization variants", { ss, sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_match(ea$earlyExit, "fewer than two variants") expect_equal(length(res[[1L]]), 1L) }) @@ -6346,7 +5604,7 @@ test_that("summaryStatsQc: kriging QC records its audit and rollup", { joined <- paste(msgs, collapse = "") expect_match(joined, "kriging sign-flipped") expect_match(joined, "kriging-flip ") - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_true("krigingFlipped" %in% names(ea)) expect_true("krigingDiagnostics" %in% names(ea)) kd <- ea$krigingDiagnostics @@ -6405,7 +5663,7 @@ test_that("summaryStatsQc: impute assembles BETA/SE/N, median-fills N", { impute = TRUE, raissParam = RaissParam(flank = 500) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_equal(ea$raissTotalVariants, 6L) expect_equal(ea$raissImputedVariants, 2L) mc <- S4Vectors::mcols(res[[1L]]) @@ -6552,7 +5810,7 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { # The chr99 variant lands in its own ELEMENT (entries are split by seqname # at construction), so the audit is now per (study, chromosome) and the # drop counts are summed across entries rather than read off entry 1. - audits <- qcInfo(res)$entryAudit + audits <- res$qcAudit tally <- function(section, field) { sum(unlist(map(map(audits, section), field))) } @@ -6580,61 +5838,11 @@ test_that("summaryStatsQc: the rollup enumerates every removed step", { } }) -test_that("dentistSingleWindow: rsq warning on a near-singular LD block", { - # Highly collinear LD with a moderately strong signal can push the C++ - # adjusted rsq_eigen above 1, exercising the withCallingHandlers capture / - # summary-warning path. The call is wrapped to stay robust either way. - set.seed(123) - m <- 60 - R <- matrix(0.999, m, m) - diag(R) <- 1 - z <- as.numeric(R %*% rnorm(m, sd = 3)) - res <- suppressWarnings( - dentistSingleWindow( - z, - R = R, - nSample = 50, - propSVD = 0.95, - duprThreshold = 1.0 - ) - ) - expect_equal(nrow(res), m) -}) - # =========================================================================== # Final-coverage closeouts: a handful of branch/error-handler lines that the # existing suite leaves untouched. # =========================================================================== -test_that("harmonizeAlleles renames an empty target column to unnamed_N", { - # 5 columns whose first four are positional (NOT literally named - # chrom/pos/A2/A1), so harmonizeAlleles routes through parseVariantId -- which - # preserves the extra column -- rather than the select()-based path. The 5th - # column has an empty name, so the joined matchResult carries an empty-named - # column and sanitizeNames() rewrites it to "unnamed_1" (sumstatsQc.R:83). - target <- data.frame( - CHR = c(1, 1, 1), - POS = c(100, 200, 300), - ref = c("A", "C", "G"), - alt = c("G", "T", "A"), - extra = c(0.1, 0.2, 0.3), - stringsAsFactors = FALSE - ) - names(target)[5] <- "" - ref <- data.frame( - chrom = c(1, 1, 1), - pos = c(100, 200, 300), - A2 = c("A", "C", "G"), - A1 = c("G", "T", "A"), - stringsAsFactors = FALSE - ) - res <- pecotmr:::harmonizeAlleles(target, ref, matchMinProp = 0) - expect_equal(nrow(res$harmonizedData), 3L) - nm <- colnames(res$harmonizedData) - expect_false(any(nm == "" | is.na(nm))) # the empty name was repaired - expect_true(any(grepl("^unnamed_", nm))) # ... to an "unnamed_*" label -}) - test_that("dentistSingleWindow summarizes the cpp11 rsqExceed field", { # The cpp11 imputer returns any rsq values it capped at 1.0 in `rsqExceed`; # .dentistRunImpute reads that field and summarizes it into a single @@ -6681,9 +5889,9 @@ test_that("dentistSingleWindow summarizes the cpp11 rsqExceed field", { }) test_that("segmentByDist keeps a last window that clears the cutoff", { - # A single dense block spanning 1.25x the distance cutoff produces two windows - # whose final window is wide enough that adjustLastFn does NOT shrink it: the - # else branch returns the current startIdx unchanged (sumstatsQc.R:1095). + # A single dense block spanning 1.25x the distance cutoff produces two + # windows whose final window is wide enough that adjustLastFn does NOT + # shrink it: it keeps the current startIdx unchanged. pos <- as.integer(round(seq(1, 1250000, length.out = 600))) win <- pecotmr:::segmentByDist(pos, maxDist = 1000000, minDim = 500) expect_true(is.data.frame(win)) @@ -6776,7 +5984,7 @@ test_that("summaryStatsQc kriging QC sign-flips and keeps a bad variant", { sumstatsFilterParam = SumstatsFilterParam(nCutoff = 0) ) ) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_gte(ea$krigingFlipped, 1L) # at least one flipped expect_equal(length(res[[1L]]), 8L) # retained, not dropped # rs4's -15 flips to +15; its neighbours were +4, so every retained Z is now @@ -6799,7 +6007,7 @@ test_that(".subsetLdRefToRange keeps panel variants in the entry span", { chIdx <- which(si$CHR == ch) slice <- si[chIdx[seq_len(min(30L, length(chIdx)))], , drop = FALSE] gr <- GenomicRanges::GRanges( - paste0("chr", slice$CHR), + slice$CHR, IRanges::IRanges(as.integer(slice$BP), width = 1L) ) S4Vectors::mcols(gr)$SNP <- slice$SNP @@ -6807,7 +6015,7 @@ test_that(".subsetLdRefToRange keeps panel variants in the entry span", { lo <- min(slice$BP) hi <- max(slice$BP) expected <- si$SNP[ - pecotmr:::canonChrom(si$CHR) == pecotmr:::canonChrom(ch) & + si$CHR == ch & as.integer(si$BP) >= lo & as.integer(si$BP) <= hi ] @@ -6823,7 +6031,7 @@ test_that(".subsetLdRefToIds keeps exactly the entries' variants", { si <- snpInfo(h) sel <- c(3L, 10L, 40L, 200L) gr <- GenomicRanges::GRanges( - paste0("chr", si$CHR[sel]), + si$CHR[sel], IRanges::IRanges(as.integer(si$BP[sel]), width = 1L) ) S4Vectors::mcols(gr)$SNP <- si$SNP[sel] @@ -6867,7 +6075,7 @@ test_that(".subsetLdRefToRange / .subsetLdRefToIds are NULL-safe", { .ssqcPanelSumStats <- function(handle) { si <- snpInfo(handle) gr <- GenomicRanges::GRanges( - seqnames = paste0("chr", si$CHR), + seqnames = si$CHR, ranges = IRanges::IRanges(start = as.integer(si$BP), width = 1L) ) set.seed(11) @@ -6957,7 +6165,7 @@ test_that("summaryStatsQc: mafCutoff drops panel-rare observed variants", { 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:::.ldRefHandle(ldReference(out)) + seed <- pecotmr:::.ldRefHandle(ldReference(out)[[1L]]) keptMaf <- maf[match( as.character(snpInfo(seed)$SNP), as.character(snpInfo(h)$SNP) @@ -7263,18 +6471,10 @@ test_that("a dropped ambiguous variant is not re-imputed, nor is its flip", { expect_false(is_in(normalizeVariantId("chr1:100:AT:A"), got)) }) -test_that("a flip pair is excluded even when nothing is known there", { +test_that("with nothing known, only the flip pair escapes imputation", { # The ambiguity is a property of the panel, not of what the sumstats - # happen to carry. - got <- .raiss_targets(character(0)) - expect_false(any(is_in( - normalizeVariantId(c("chr1:100:A:AT", "chr1:100:AT:A")), - got - ))) -}) - -test_that("unambiguous variants are still imputed", { - # The guard must not cost coverage where there is no ambiguity. + # happen to carry -- and the guard must not cost coverage where there is + # no ambiguity: exactly the unambiguous variants are imputed. expect_setequal( .raiss_targets(character(0)), normalizeVariantId(c("chr1:400:A:G", "chr1:500:C:T")) @@ -7297,17 +6497,12 @@ test_that(".raissFlipPairMask needs both orientations, not just an indel", { expect_equal(.raissFlipPairMask(ids), c(TRUE, TRUE, FALSE, FALSE)) }) -test_that(".raissFlipPairMask sees a strand-recorded second orientation", { - # A:G and C:T are one variant written on opposite strands AND swapped, so - # matchVariants() refuses the position. A literal A1/A2 reversal key read - # this as two unrelated variants and let RAISS impute the pair back. - ids <- normalizeVariantId(c("chr1:100:A:G", "chr1:100:C:T")) - expect_equal(.raissFlipPairMask(ids), c(TRUE, TRUE)) -}) - test_that(".raissFlipPairMask agrees with matchVariants on what is ambiguous", { # The mask exists to stop imputation putting back what matchVariants drops, - # so the two have to answer the same question the same way. + # so the two have to answer the same question the same way. chr1:100's + # A:G and C:T are one variant written on opposite strands AND swapped, so + # matchVariants() refuses the position; a literal A1/A2 reversal key read + # this as two unrelated variants and let RAISS impute the pair back. ids <- normalizeVariantId(c( "chr1:100:A:G", "chr1:100:C:T", @@ -7385,21 +6580,12 @@ test_that(".raissFlipOfKnownMask flags a flip regardless of position", { ) }) -test_that("a second allele at a typed position is not imputed", { +test_that("a typed position imputes no second allele, untyped ones all forms", { # Imputation fills UN-observed variants; another form of a site the GWAS - # measured is a redundant record, not new information. - d <- .raiss_pr573() - idx <- .raissUnknownIdx( - d$refPanel, - d$knownZ, - intersect(d$knownZ$variant_id, d$refPanel$variant_id) - ) - expect_false(is_in("1:100:A:T", d$refPanel$variant_id[idx])) -}) - -test_that("un-observed positions still impute every panel form they have", { - # The guard is about MEASURED positions, not about multi-allelic sites: - # 1:300 is multi-allelic but untyped, so both its forms are targets. + # measured is a redundant record, not new information, so 1:100:A:T is + # no target. The guard is about MEASURED positions, not about + # multi-allelic sites: 1:300 is multi-allelic but untyped, so both its + # forms are targets. d <- .raiss_pr573() idx <- .raissUnknownIdx( d$refPanel, @@ -7412,13 +6598,20 @@ test_that("un-observed positions still impute every panel form they have", { ) }) -test_that("the position guard is chr-prefix tolerant", { - # "chr1" in the panel and "1" in the sumstats is one site, not two. +test_that("raiss() reads either chromosome spelling as one site", { + # "chr1" in the panel and "1" in the sumstats is one site, not two: + # raiss() spells both tables' chromosomes in UCSC style as they come in. d <- .raiss_pr573() d$refPanel$chrom <- str_c("chr", d$refPanel$chrom) - d$refPanel$variant_id <- str_c("chr", d$refPanel$variant_id) - idx <- .raissUnknownIdx(d$refPanel, d$knownZ, character(0)) - expect_false(is_in("chr1:100:A:T", d$refPanel$variant_id[idx])) + ld <- diag(5) + ld[1, 2] <- ld[2, 1] <- 0.7 + ld[1, 3] <- ld[3, 1] <- 0.6 + ld[1, 4] <- ld[4, 1] <- 0.5 + ld[1, 5] <- ld[5, 1] <- 0.45 + r <- raiss(d$refPanel, d$knownZ, ldMatrix = ld, verbose = FALSE) + imp <- setdiff(r$resultNofilter$variant_id, d$knownZ$variant_id) + expect_false(is_in("1:100:A:T", imp)) + expect_true(all(r$resultNofilter$chrom == "chr1")) }) test_that("raissSingleMatrix does not impute at a typed position", { @@ -7447,13 +6640,6 @@ test_that("raissSingleMatrix does not impute at a typed position", { # that is ~135 MB of dead weight serialized per such entry. # =========================================================================== -.sk_panel <- function() { - readGenotypes( - test_path("test_data", "test_variants"), - format = "plink1" - ) -} - test_that("both trimmers empty the sketch for zero-variant entries", { h <- .sk_panel() expect_gt(nrow(h), 0L) @@ -7477,26 +6663,6 @@ test_that("emptying drops both axes but keeps the panel's identity", { expect_equal(.ldRefSource(e)$path, .ldRefSource(h)$path) }) -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 <- .emptyLdRef(h) - expect_equal(nrow(e), 0L) - expect_null(.panelSeed(e)) - expect_lt( - length(serialize(e, NULL)), - length(serialize(h, NULL)) / 2 - ) -}) - -test_that(".emptyLdRef is NULL-safe and idempotent", { - expect_null(.emptyLdRef(NULL)) - e <- .emptyLdRef(.sk_panel()) - expect_equal(nrow(.emptyLdRef(e)), 0L) -}) - 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 @@ -7518,90 +6684,6 @@ test_that(".subsetLdRefToIds keeps the panel when ids are unextractable", { # NA instead of a silently mislabelled minor-allele frequency. # =========================================================================== -.afm_df <- function(freqcol, val) { - d <- data.frame( - chrom = "chr1", - pos = 100L, - variant_id = "chr1:100:A:G", - A1 = "A", - A2 = "G", - z = 2.5, - n_sample = 1000, - stringsAsFactors = FALSE - ) - d[[freqcol]] <- val - d -} - -.afm_cm <- function(...) { - c( - chrom = "chrom", - pos = "pos", - variant_id = "variant_id", - A1 = "A1", - A2 = "A2", - z = "z", - n_sample = "n_sample", - ... - ) -} - -test_that("an af: key is directional AF; a maf: key is directionless", { - # Same source column, different declaration -> different meaning. - a <- suppressWarnings(.resolveSumstatCols( - .afm_df("effect_allele_frequency", 0.8), - .afm_cm(af = "effect_allele_frequency"), - "af" - )) - expect_equal(a$AF, 0.8) - expect_false("MAF" %in% names(a)) - b <- suppressWarnings(.resolveSumstatCols( - .afm_df("effect_allele_frequency", 0.8), - .afm_cm(maf = "effect_allele_frequency"), - "maf" - )) - expect_false("AF" %in% names(b)) - expect_equal(b$MAF, 0.8) -}) - -test_that("an undeclared af warns distinctly and yields no AF column", { - expect_warning( - out <- .resolveSumstatCols( - .afm_df("maf", 0.2), - .afm_cm(maf = "maf"), - "undeclared" - ), - "no effect-allele frequency declared" - ) - expect_false("AF" %in% names(out)) -}) - -test_that("a declared-but-unusable af warns with a different message", { - # Distinct from "undeclared": this is a data problem, not a mapping one. - expect_warning( - .resolveSumstatCols( - .afm_df("eaf", NA_real_), - .afm_cm(af = "eaf"), - "missing" - ), - "declared but its values are all missing" - ) -}) - -test_that(".fmAfByVar reads AF, and is NULL when af was never declared", { - mk <- function(cm) { - .dfToEntryGranges(suppressWarnings(.resolveSumstatCols( - .afm_df("effect_allele_frequency", 0.8), - cm, - "lbl" - ))) - } - gA <- mk(.afm_cm(af = "effect_allele_frequency")) - expect_equal(unname(.fmAfByVar(gA, "chr1:100:A:G")), 0.8) - gM <- mk(.afm_cm(maf = "effect_allele_frequency")) - expect_null(.fmAfByVar(gM, "chr1:100:A:G")) -}) - test_that(".cfMaf prefers af, falls back to maf, and skips when neither", { expect_equal(nrow(.cfMaf(data.frame(AF = c(0.8, 0.01)), 0.05)$df), 1L) expect_equal(nrow(.cfMaf(data.frame(MAF = c(0.2, 0.01)), 0.05)$df), 1L) @@ -7769,15 +6851,6 @@ test_that("RaissParam carries rcond for an LdMatrix reference", { expect_equal(RaissParam()$rcond, formals(raiss)$rcond) }) -test_that("RaissParam fields split into raiss formals and pecotmr's own", { - 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. - ours <- c("mafCutoff", "macCutoff", "imissCutoff", "flank") - expect_false(any(ours %in% names(formals(raiss)))) -}) - test_that("summaryStatsQc refuses a bare list for raissParam", { data(gwasSumStatsS4Example) expect_error( @@ -7796,8 +6869,13 @@ test_that("an empty raissParam resolves to the full default bundle", { test_that("the forwarded half of RaissParam is exactly raiss's own formals", { fwd <- pecotmr:::.raissForwardedNames() + expect_setequal( + fwd, + c("lamb", "rcond", "svdTol", "r2Threshold", "minimumLd") + ) expect_true(all(fwd %in% names(formals(raiss)))) - # The other half never reaches raiss; splicing it in would be an error. + # The other half scopes what RAISS is asked to impute and is consumed + # before the call; splicing it into raiss would be an error. rest <- setdiff(names(RaissParam()), fwd) expect_false(any(rest %in% names(formals(raiss)))) expect_setequal( @@ -7851,7 +6929,7 @@ test_that(".sumstatsCleaningResolve fills defaults an empty bundle omits", { test_that("summaryStatsQc gives one result from an LdMatrix and its panel", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example - panel <- ldReference(gss) + panel <- ldReference(gss)[[1L]] ld <- LdMatrix( unname(computeLd(panel)), variants = SummarizedExperiment::rowRanges(panel), @@ -7862,7 +6940,7 @@ test_that("summaryStatsQc gives one result from an LdMatrix and its panel", { entry = list(.collectionEntry(gss, 1L)), genome = "hg19", ldReference = ld, - qcInfo = qcInfo(gss) + qcOptions = qcOptions(gss) ) viaPanel <- suppressMessages( summaryStatsQc(gss, ldMismatchQcMethod = "slalom") @@ -7875,8 +6953,11 @@ test_that("summaryStatsQc gives one result from an LdMatrix and its panel", { 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))) + expect_s4_class(ldReference(viaMatrix)[[1L]], "LdMatrix") + expect_equal( + length(ldReference(viaMatrix)[[1L]]), + length(unlist(viaMatrix)) + ) }) test_that("DENTIST needs an LdMatrix's size; SLALOM does not", { @@ -7894,7 +6975,7 @@ test_that("DENTIST needs an LdMatrix's size; SLALOM does not", { test_that("RAISS imputation in QC runs on an LdMatrix reference", { data(gwasSumStatsS4Example) gss <- gwasSumStatsS4Example - panel <- ldReference(gss) + panel <- ldReference(gss)[[1L]] ld <- LdMatrix( unname(computeLd(panel)), variants = SummarizedExperiment::rowRanges(panel), @@ -7908,7 +6989,7 @@ test_that("RAISS imputation in QC runs on an LdMatrix reference", { ldReference = ld ) res <- suppressMessages(summaryStatsQc(thin, impute = TRUE)) - ea <- qcInfo(res)$entryAudit[[1L]] + ea <- res$qcAudit[[1L]] expect_gt(ea$raissImputedVariants, 0L) # Target filters read the LdMatrix's AF, which this one does not record. expect_error( @@ -7920,3 +7001,330 @@ test_that("RAISS imputation in QC runs on an LdMatrix reference", { "needs allele frequencies" ) }) + +test_that("summaryStatsQc QCs each row against its own LD reference", { + # One row on the panel, another on the same LD as a matrix: each is + # harmonized against its own and keeps it, cut to its own variants. + data(qtlSumStatsMulticontextExample) + mc <- qtlSumStatsMulticontextExample + panel <- ldReference(mc)[[1L]] + ldm <- LdMatrix( + unname(computeLd(panel)), + variants = SummarizedExperiment::rowRanges(panel) + ) + refs <- rep(list(panel), nrow(mc)) + refs[[2L]] <- ldm + out <- suppressMessages(summaryStatsQc(pecotmr:::.withRowLdRefs(mc, refs))) + expect_length(ldReference(out), 2L) + expect_s4_class( + pecotmr:::.rowLdRef(out, 1L), + "RangedSummarizedExperiment" + ) + expect_s4_class(pecotmr:::.rowLdRef(out, 2L), "LdMatrix") + expect_equal(length(pecotmr:::.rowLdRef(out, 2L)), length(out[[2L]])) +}) + +# =========================================================================== +# RAISS's flank stops at a row's own LD block +# =========================================================================== + +# Every fourth variant of the bundled example, so RAISS has targets, split +# into two LD blocks of one study. `blockId` names the blocks, or leaves +# their coordinates as their keys. +.qcb_thinBlocked <- function(blockId = NULL) { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + variants <- unlist(gss) + blocks <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(1L, 15200001L), c(15200000L, 51304566L)) + ) + if (!is.null(blockId)) { + S4Vectors::mcols(blocks)$blockId <- blockId + } + GwasSumStats( + studyName = studyName(gss), + entry = list(variants[seq(1L, length(variants), by = 4L)]), + genome = unique(unname(GenomeInfoDb::genome(gss))), + ldReference = ldReference(gss), + qcOptions = list(step1 = "ok"), + region = blocks + ) +} + +test_that(".ssqcRaissBounds keeps each row of a split study to its block", { + x <- .qcb_thinBlocked() + on <- list(impute = TRUE, raissParam = list(flank = 1e5)) + bounds <- pecotmr:::.ssqcRaissBounds(x, on) + # The blocks' ranges were given, so the blocks are their own bounds, + # whether the manifest keys them by their coordinates or by name. + expect_identical( + map_chr(bounds, as.character), + c("chr22:1-15200000", "chr22:15200001-51304566") + ) + named <- pecotmr:::.ssqcRaissBounds(.qcb_thinBlocked(c("a", "b")), on) + expect_identical( + map_chr(named, as.character), + c("chr22:1-15200000", "chr22:15200001-51304566") + ) + # Rows whose ranges are only their spans fall back to halfway between. + computed <- x + computed$regionGiven <- c(FALSE, FALSE) + labelled <- pecotmr:::.ssqcRaissBounds(computed, on) + spans <- range(x) + gap <- (GenomicRanges::end(spans[[1L]]) + + GenomicRanges::start(spans[[2L]])) %/% + 2L + expect_identical(GenomicRanges::end(labelled[[1L]]), gap) + expect_identical(GenomicRanges::start(labelled[[2L]]), gap + 1L) + # No flank, or no imputation, needs no bound; nor does a lone row. + expect_true(all(map_lgl( + pecotmr:::.ssqcRaissBounds( + x, + list(impute = TRUE, raissParam = list(flank = 0)) + ), + is.null + ))) + expect_true(all(map_lgl( + pecotmr:::.ssqcRaissBounds(x, list(impute = FALSE)), + is.null + ))) + data(gwasSumStatsS4Example) + expect_null( + pecotmr:::.ssqcRaissBounds(gwasSumStatsS4Example, on)[[1L]] + ) + # A lone row given its block keeps to it all the same: what lies past + # its range is another block, loaded or not. + lone <- x[1L] + expect_identical( + as.character(pecotmr:::.ssqcRaissBounds(lone, on)[[1L]]), + "chr22:1-15200000" + ) +}) + +test_that(".ssqcMidpointBounds splits gaps; an overlap keeps its own span", { + own <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, 200L)) + sib <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(10L, 300L), c(50L, 400L)) + ) + mid <- pecotmr:::.ssqcMidpointBounds(own, sib) + expect_identical(GenomicRanges::start(mid), 76L) + expect_identical(GenomicRanges::end(mid), 250L) + # Neighbours on one side only leave the other side open. + below <- pecotmr:::.ssqcMidpointBounds(own, sib[1L]) + expect_identical(GenomicRanges::end(below), .Machine$integer.max) + above <- pecotmr:::.ssqcMidpointBounds(own, sib[2L]) + expect_identical(GenomicRanges::start(above), 1L) + over <- GenomicRanges::GRanges("chr1", IRanges::IRanges(150L, 400L)) + expect_identical(pecotmr:::.ssqcMidpointBounds(own, over), own) +}) + +test_that(".qcRaissClampBounds narrows only the clamp's chromosome", { + bounds <- tibble::tibble( + chrom = c("chr1", "chr2"), + lo = c(50L, 50L), + hi = c(500L, 500L) + ) + clamp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, 300L)) + out <- pecotmr:::.qcRaissClampBounds(bounds, clamp) + expect_identical(out$lo, c(100L, 50L)) + expect_identical(out$hi, c(300L, 500L)) + expect_identical(pecotmr:::.qcRaissClampBounds(bounds, NULL), bounds) +}) + +test_that("RAISS with a flank imputes each variant of a split study once", { + x <- .qcb_thinBlocked() + out <- suppressWarnings(suppressMessages(summaryStatsQc( + x, + impute = TRUE, + raissParam = RaissParam(flank = 2e5, r2Threshold = 0, minimumLd = 0) + ))) + expect_gt(sum(lengths(out)), sum(lengths(x))) + ids <- map(as.list(out), function(el) S4Vectors::mcols(el)$SNP) + expect_length(intersect(ids[[1L]], ids[[2L]]), 0L) + # Each row stays inside its own block. + expect_lte(max(GenomicRanges::end(out[[1L]])), 15200000L) + expect_gte(min(GenomicRanges::start(out[[2L]])), 15200001L) +}) + +test_that("a signal screen may empty every block of a study", { + x <- .qcb_thinBlocked() + out <- suppressMessages(summaryStatsQc( + x, + signalScreenParam = SignalScreenParam(absZ = 1e6) + )) + expect_equal(unname(lengths(out)), c(0L, 0L)) + expect_identical(out$blockId, x$blockId) + # The blocks were given their ranges, which they keep with no variant + # left in them. + expect_identical(out$regionGiven, c(TRUE, TRUE)) + expect_identical(out$region, x$region) +}) + +test_that("a QC pass carries each row's window unchanged", { + x <- .qcb_thinBlocked(c("a", "b")) + out <- suppressMessages(summaryStatsQc(x)) + expect_identical(out$blockId, c("a", "b")) + expect_identical(out$regionGiven, c(TRUE, TRUE)) + expect_identical(out$region, x$region) + # A computed window is the span the row was first built with: QC dropping + # an edge variant does not move it, and range(x) gives what is left. + data(gwasSumStatsS4Example) + v <- sumStats(gwasSumStatsS4Example) + S4Vectors::mcols(v)$Z[[1L]] <- NA + built <- GwasSumStats( + studyName = "s", + entry = list(v), + genome = "hg19", + ldReference = ldReference(gwasSumStatsS4Example)[[1L]], + qcOptions = list(step1 = "ok") + ) + qc <- suppressWarnings(suppressMessages(summaryStatsQc(built))) + expect_false(qc$regionGiven) + expect_identical(qc$region, built$region) + expect_gt( + GenomicRanges::start(range(qc[[1L]])), + GenomicRanges::start(qc$region) + ) +}) + +test_that("a QC pass keeps a QtlSumStats's trait position and columns", { + data(qtlSumStatsExample) + q <- qtlSumStatsExample + g <- q[[1L]] + tp <- GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(g))[[1L]], + IRanges::IRanges(GenomicRanges::start(g)[[50L]], width = 1L) + ) + y <- QtlSumStats( + studyName = q$study, + context = q$context, + trait = q$trait, + entry = list(g), + genome = unique(GenomeInfoDb::genome(q)), + ldReference = ldReference(q)[[1L]], + traitPos = tp, + extraCols = list(tag = "kept") + ) + out <- suppressMessages(summaryStatsQc(y)) + expect_identical(as.character(out$traitPos), as.character(tp)) + expect_identical(out$tag, "kept") + expect_identical(out$region, y$region) +}) + +test_that(".ssqcRaissBounds leaves an emptied row unbounded", { + x <- .qcb_thinBlocked() + emptied <- GwasSumStats( + studyName = "trait1", + entry = list(sumStats(x)[0L]), + genome = "hg19", + ldReference = ldReference(x)[[1L]], + qcOptions = list(step1 = "ok"), + blockId = "screened" + ) + both <- combineGwasSumStats(x, emptied) + expect_equal(unname(lengths(both)), c(unname(lengths(x)), 0L)) + bounds <- pecotmr:::.ssqcRaissBounds( + both, + list(impute = TRUE, raissParam = list(flank = 1e5)) + ) + # An empty row has no chromosome to share, so it is never bounded; the + # two blocks still bound each other. + expect_null(bounds[[3L]]) + expect_false(is.null(bounds[[1L]])) + expect_false(is.null(bounds[[2L]])) +}) + +# =========================================================================== +# On a real genotype panel: dentistSingleWindow +# =========================================================================== + +test_that("dentistSingleWindow detects injected outliers", { + skip_if_not_installed("pgenlibr") + # 100 samples x 349 variants on chr21 + X <- loadGenotypeRegion(test_path("test_data", "test_variants")) + R <- computeLd(X, method = "sample") + set.seed(42) + z <- rnorm(ncol(X)) + # Inject extreme outliers + z[1] <- 50 + z[2] <- -50 + result <- suppressWarnings(dentistSingleWindow(z, R = R, nSample = nrow(X))) + # At least one of the injected values should be flagged + expect_true(any(result$outlier)) +}) + +# =========================================================================== +# .entryToSumstatDf +# =========================================================================== + +test_that(".entryToSumstatDf: returns the canonical column layout", { + ss <- .gsd_makeGwasSumStats(data.frame( + SNP = c("rs1", "rs2"), + A1 = c("A", "A"), + A2 = c("G", "G"), + Z = c(1.0, -2.5), + N = c(1000L, 1500L), + MAF = c(0.1, 0.3) + )) + df <- pecotmr:::.entryToSumstatDf(sumStats(ss)) + expect_s3_class(df, "data.frame") + expect_equal(df$variant_id, c("rs1", "rs2")) + expect_equal(df$chrom, c("chr1", "chr1")) + expect_equal(df$pos, c(100L, 200L)) + expect_equal(df$z, c(1.0, -2.5)) + expect_equal(df$N, c(1000, 1500)) + expect_equal(df$maf, c(0.1, 0.3)) +}) + +test_that(".entryToSumstatDf: derives z from beta/se on request", { + ss <- .gsd_makeGwasSumStats( + data.frame( + SNP = "rs1", + A1 = "A", + A2 = "G", + BETA = 0.5, + SE = 0.1, + N = 1000L + ), + snp_n = 1L + ) + df <- pecotmr:::.entryToSumstatDf(sumStats(ss), derive = "zFromBetaSe") + expect_equal(df$beta, 0.5) + expect_equal(df$se, 0.1) + expect_equal(df$z, 0.5 / 0.1) +}) + +test_that(".entryToSumstatDf: omits optional columns when absent", { + ss <- .gsd_makeGwasSumStats( + data.frame( + SNP = "rs1", + A1 = "A", + A2 = "G" + ), + snp_n = 1L + ) + df <- pecotmr:::.entryToSumstatDf(sumStats(ss)) + expect_false("z" %in% names(df)) + expect_false("beta" %in% names(df)) + expect_false("se" %in% names(df)) + expect_false("N" %in% names(df)) + expect_false("maf" %in% names(df)) +}) + +test_that(".entryToSumstatDf: require = c('Z', 'N') errors when missing", { + ss <- .gsd_makeGwasSumStats( + data.frame( + SNP = "rs1", + A1 = "A", + A2 = "G", + Z = 1.5 + ), + snp_n = 1L + ) + expect_error( + pecotmr:::.entryToSumstatDf(sumStats(ss), require = c("Z", "N")), + "no N mcol" + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 203590bb..861a268f 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -198,11 +198,11 @@ test_that(".tupleSelectRowGwasFmr: missing selectors on multi-row errors", { ) expect_error( pecotmr:::.tupleSelectRowGwasFmr(multi), - "Pass `study` and `method`" + "Pass `studyName` and `method`" ) }) -test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { +test_that(".tupleSelectRowGwasFmr: non-scalar blockId errors", { multi <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), @@ -214,14 +214,14 @@ test_that(".tupleSelectRowGwasFmr: non-scalar region errors", { multi, studyName = "g1", method = "susie", - region = c("r1", "r2") + blockId = c("r1", "r2") ), - "region.*Must have length 1" + "blockId.*Must have length 1" ) }) -test_that(".tupleSelectRowGwasFmr: region disambiguates per-block rows", { - # Same (study, method) across two regions; region picks the right row. +test_that(".tupleSelectRowGwasFmr: blockId disambiguates per-block rows", { + # Same (study, method) across two blocks; blockId picks the right row. multi <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), @@ -233,13 +233,13 @@ test_that(".tupleSelectRowGwasFmr: region disambiguates per-block rows", { multi, studyName = "g1", method = "susie", - region = "chr22_500_600" + blockId = "chr22_500_600" ), 2L ) }) -test_that(".tupleSelectRowGwasFmr: missing tuple errors and includes region in message", { +test_that(".tupleSelectRowGwasFmr: a missing tuple's error names its blockId", { one <- .ts_coll( study = "g1", method = "susie", @@ -251,13 +251,13 @@ test_that(".tupleSelectRowGwasFmr: missing tuple errors and includes region in m one, studyName = "g1", method = "susie", - region = "ghost" + blockId = "ghost" ), - "region='ghost'" + "blockId='ghost'" ) }) -test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candidates", { +test_that(".tupleSelectRowGwasFmr: ambiguous multi-match lists the blocks", { # Two rows share (study, method); .tupleSelectRowGwasFmr should error # listing the available blockIds since the caller didn't disambiguate. multi <- .ts_coll( @@ -272,7 +272,7 @@ test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candi studyName = "g1", method = "susie" ), - "pass `region` to disambiguate" + "pass `blockId` to disambiguate" ) }) @@ -315,14 +315,14 @@ test_that(".fmrRowsMatching: selectors on absent columns are ignored", { expect_equal(pecotmr:::.fmrRowsMatching(gwas, context = "c1"), c(1L, 2L)) }) -test_that(".fmrRowsMatching: `region` matches the blockId column", { +test_that(".fmrRowsMatching: `blockId` matches the blockId column", { gwas <- .ts_coll( study = c("g1", "g1"), method = c("susie", "susie"), blockId = c("r1", "r2"), stringsAsFactors = FALSE ) - expect_equal(pecotmr:::.fmrRowsMatching(gwas, region = "r2"), 2L) + expect_equal(pecotmr:::.fmrRowsMatching(gwas, blockId = "r2"), 2L) }) test_that(".fmrRowsMatching: a vector selector matches any listed value", { @@ -340,7 +340,7 @@ test_that(".fmrRowsMatching: a vector selector matches any listed value", { }) # =========================================================================== -# .fmrRowMetadata (stable 5-column identity frame) +# .fmrRowMetadata (stable 8-column identity frame) # =========================================================================== test_that(".fmrRowMetadata: emits all eight identity columns, NA-filling absent ones", { @@ -382,7 +382,7 @@ test_that(".fmrRowMetadata: GWAS frame NA-fills context/trait, keeps blockId", { expect_true(all(is.na(m$trait))) }) -test_that(".fmrRowMetadata: zero-row input yields a zero-row 5-column frame", { +test_that(".fmrRowMetadata: zero-row input yields a zero-row 8-column frame", { empty <- .ts_coll( study = character(0), method = character(0), @@ -452,11 +452,8 @@ test_that(".getRegionColumn: a zero-row collection yields an empty GRanges", { }) test_that(".appendBlockIdCol: blockId must match the row count", { - # Replaces the old .appendRegionCol / .validateRegionColumn pair. The - # stored `region` GRanges column retired because it had no correct update - # rule under subsetRegion() -- it would simply go stale. blockId is a - # label keying the external block manifest, so subsetting cannot - # invalidate it. + # blockId is a label keying the external block manifest, so subsetting + # cannot invalidate it. expect_equal(pecotmr:::.appendBlockIdCol(list(), NULL, 2L), list()) expect_equal( pecotmr:::.appendBlockIdCol(list(), c("b1", "b2"), 2L)$blockId, @@ -468,15 +465,6 @@ test_that(".appendBlockIdCol: blockId must match the row count", { ) }) -test_that(".getRegionColumn derives the span rather than reading a column", { - # The one range concept is the intrinsic element range; there is no stored - # window to fall back to any more. - data(gwasFineMappingExample, envir = environment()) - gr <- pecotmr:::.getRegionColumn(gwasFineMappingExample) - expect_s4_class(gr, "GRanges") - expect_length(gr, nrow(gwasFineMappingExample)) -}) - test_that(".appendTraitPosCol: traitPos must be a GRanges of matching length", { expect_error( pecotmr:::.appendTraitPosCol(list(), "notgranges", 1L), @@ -533,10 +521,10 @@ test_that("an exemplar column absent from every part is NULL", { # Combining collections: QC records and chromosome-path unions # =========================================================================== -test_that("combining inputs that carry no QC record yields an empty audit", { +test_that("combining inputs that carry no QC record yields no QC options", { # Empty, not a fabricated record: claiming QC that never ran would be # worse than reporting none. - expect_equal(pecotmr:::.ssCombineQcInfo(list(), "combineX"), list()) + expect_equal(pecotmr:::.ssCombineQcOptions(list(), "combineX"), list()) }) test_that("chromosome paths union when they agree and abort when they clash", { @@ -549,7 +537,7 @@ test_that("chromosome paths union when they agree and abort when they clash", { format = "plink2", snpInfo = data.frame( SNP = "a", - CHR = "1", + CHR = "chr1", BP = 1L, A1 = "A", A2 = "G", @@ -579,15 +567,19 @@ 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. + # order. A panel from another file is another source, and kept apart. 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)) + merged <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(a, b)), + "combineX" + ) + expect_identical(merged$keys, c("ld1", "ld1")) + out <- merged$refs$ld1 expect_identical(rownames(out), rownames(panel)[1:8]) expect_equal( as.matrix(SummarizedExperiment::assay(out, "dosage")), @@ -599,13 +591,11 @@ test_that("panels read through no handle union their rows", { ) # 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" + apart <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(a, readGenotypes(plink2Prefix = stem))), + "combineX" ) + expect_length(apart$refs, 2L) }) @@ -673,7 +663,7 @@ test_that("a collection-level slot with no merge rule is refused", { }) test_that(".twrRowResolveWeights drops rows whose weights are all NA", { - allNa <- twasWeightsRow( + allNa <- TwasWeightsRow( variantIds = c("chr1:1:A:G", "chr1:2:C:T"), weights = c(NA_real_, NA_real_) ) @@ -682,7 +672,7 @@ test_that(".twrRowResolveWeights drops rows whose weights are all NA", { expect_length(out$variantIds, 0L) expect_length(out$weights, 0L) # Control: a single usable weight is kept, and only that one. - partial <- twasWeightsRow( + partial <- TwasWeightsRow( variantIds = c("chr1:1:A:G", "chr1:2:C:T"), weights = c(NA_real_, 0.5) ) @@ -767,13 +757,13 @@ test_that("a region column must be a GRanges with one range per row", { ) }) -test_that(".asAnalysisWindow normalizes strings, GRanges and multi-range input", { +test_that(".asAnalysisWindow keeps a window and spans a multi-range one", { expect_null(.asAnalysisWindow(NULL)) expect_null(.asAnalysisWindow(GenomicRanges::GRanges())) - expect_identical( - as.character(.asAnalysisWindow("chr1:100-200")), - as.character(GenomicRanges::GRanges("chr1:100-200")) - ) + one <- GenomicRanges::GRanges("chr1:100-200") + expect_identical(.asAnalysisWindow(one), one) + # A window is a GRanges; a string is refused rather than read. + expect_error(.asAnalysisWindow("chr1:100-200"), "must be a GRanges") # A multi-range window collapses to the span it covered. span <- .asAnalysisWindow(GenomicRanges::GRanges(c( "chr1:100-200", @@ -785,7 +775,7 @@ test_that(".asAnalysisWindow normalizes strings, GRanges and multi-range input", }) -test_that("collections sharing one LdMatrix combine; differing ones need it", { +test_that("LdMatrix views are stored as the one covering them, in any order", { ids <- c("chr22:100:A:G", "chr22:200:C:T", "chr22:300:G:A") vars <- data.frame( chrom = "chr22", @@ -796,14 +786,654 @@ test_that("collections sharing one LdMatrix combine; differing ones need it", { ) 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. + # Two views neither of which covers the other are both kept: the LD + # between their variants is held by neither. + apart <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(ld[1:2], ld[2:3])), + "combine" + ) + expect_length(apart$refs, 2L) + # With the matrix covering both among them, both are stored as it, + # wherever it comes. + orders <- list( + list(ld[1:2], ld, ld[2:3]), + list(ld[1:2], ld[2:3], ld), + list(ld, ld[1:2], ld[2:3]) + ) + for (parts in orders) { + merged <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(parts), + "combine" + ) + expect_identical(merged$refs, list(ld1 = ld)) + expect_identical(merged$keys, rep("ld1", 3L)) + } +}) + +test_that("binding stores an LdMatrix another part's covers as that one", { + ids <- sprintf("chr1:%d:A:G", 100L * (1:6)) + r <- 0.3^abs(outer(1:6, 1:6, "-")) + wide <- LdMatrix(`dimnames<-`(r, list(ids, ids))) + narrow <- LdMatrix(`dimnames<-`(r[4:6, 4:6], list(ids[4:6], ids[4:6]))) + merged <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(wide, narrow, wide)), + "probe" + ) + expect_identical(merged$refs, list(ld1 = wide)) + expect_identical(merged$keys, c("ld1", "ld1", "ld1")) + # Matrices that do not nest are different references, and stay apart. + other <- LdMatrix( + `dimnames<-`(0.9^abs(outer(1:6, 1:6, "-")), list(ids, ids)) + ) + apart <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(wide, other)), + "probe" + ) + expect_length(apart$refs, 2L) + # A panel and a matrix are never views of one source. + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + kinds <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(wide, panel)), + "probe" + ) + expect_length(kinds$refs, 2L) +}) + +test_that("binding stores a mixture another part's covers as that one", { + panel <- readGenotypes(test_path("test_data", "test_variants.bed")) + halves <- list(a = panel[, 1:40], b = panel[, 41:100]) + mix <- GenotypeMixture(halves, mixtureWeights = c(0.5, 0.5)) + # Two views that overlap only in part are both held by the whole mixture. + merged <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(mix[1:200], mix, mix[100:349])), + "probe" + ) + expect_identical(merged$refs, list(ld1 = mix)) + expect_identical(merged$keys, c("ld1", "ld1", "ld1")) + # The same panels weighted differently are another mixture. + reweighted <- GenotypeMixture(halves, mixtureWeights = c(0.4, 0.6)) + apart <- pecotmr:::.ldRefMergeViews( + pecotmr:::.ldRefDict(list(mix, reweighted[1:200])), + "probe" + ) + expect_length(apart$refs, 2L) +}) + +# =========================================================================== +# GWAS block ranges and the QTL variants past them +# =========================================================================== + +# Ten GWAS variants at chr1:100-1000, 100 apart. +.ts_gwasVariants <- function(pos = 100L * (1:10)) { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(pos, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", pos), + A1 = "A", + A2 = "G", + Z = 0, + N = 100L + ) + gr +} + +.ts_positions <- function(pos) { + GenomicRanges::GRanges("chr1", IRanges::IRanges(pos, width = 1L)) +} + +test_that(".rowSpanRanges spans each element, an empty one a placeholder", { + v <- .ts_gwasVariants() + spans <- pecotmr:::.rowSpanRanges( + GenomicRanges::GRangesList(v[1:3], v[0], v[5:10]) + ) + expect_identical( + as.character(spans), + c("chr1:100-300", "chrUn:1-0", "chr1:500-1000") + ) + expect_identical(GenomicRanges::width(spans)[[2L]], 0L) +}) + +test_that(".asRegionRanges takes a GRanges, or reads a BED file as BED", { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(10L, 20L)) + expect_identical(pecotmr:::.asRegionRanges(gr), gr) + # A BED file's start is 0-based, and its fourth column names a window. + path <- withr::local_tempfile(fileext = ".bed") + writeLines("chr1\t9\t20\tw1", path) + w <- pecotmr:::.asRegionRanges(path) + expect_identical(as.character(w), "chr1:10-20") + expect_identical(S4Vectors::mcols(w)$blockId, "w1") + # Given in R, a window is a GRanges: a table or a range string is + # refused rather than read, and a lone string is taken for a path. + table <- data.frame(chrom = "chr1", start = 9L, end = 20L) + expect_error( + pecotmr:::.asRegionRanges(table), + "must be a GRanges or the path of a BED file" + ) + expect_error( + pecotmr:::.asRegionRanges(c("chr1:10-20", "chr2:5-8")), + "must be a GRanges or the path of a BED file" + ) + expect_error( + pecotmr:::.asRegionRanges("chr1:10-20"), + "no file exists at 'chr1:10-20'" + ) + expect_error(pecotmr:::.asRegionRanges(42), "must be a GRanges") +}) + +test_that(".assertRegionGRanges takes a GRanges and nothing else", { + gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(10L, 20L)) + expect_identical(pecotmr:::.assertRegionGRanges(gr), gr) + expect_error( + pecotmr:::.assertRegionGRanges("chr1:10-20"), + "`region` must be a GRanges" + ) +}) + +test_that(".rowRegionAt reads one row's window, or its span", { + v <- .ts_gwasVariants() + x <- GwasSumStats( + studyName = c("s", "s"), + entry = list(v[1:5], v[0L]), + genome = "hg19", + blockId = c("a", "b") + ) + expect_identical( + as.character(pecotmr:::.rowRegionAt(x, 1L)), + "chr1:100-500" + ) + # An empty row built empty has only a placeholder, so no window. + expect_null(pecotmr:::.rowRegionAt(x, 2L)) + old <- x + old$region <- NULL + expect_identical( + as.character(pecotmr:::.rowRegionAt(old, 1L)), + "chr1:100-500" + ) +}) + +test_that(".regionColumns keeps a given range and spans the rest", { + given <- GenomicRanges::GRanges( + c("chr1", "chrUn"), + IRanges::IRanges(1L, c(5000L, 0L)) + ) + spans <- GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, 300L)) + cols <- pecotmr:::.regionColumns(given, c(TRUE, FALSE), rep(spans, 2L)) + expect_identical(cols$regionGiven, c(TRUE, FALSE)) expect_identical( - pecotmr:::.combineLdMatrixRefs(list(ld, ld[1:2]), "combine"), - ld + as.character(cols$region), + c("chr1:1-5000", "chr1:100-300") + ) + # A row with no variants keeps the range it was given. + empty <- pecotmr:::.regionColumns( + given[1L], + TRUE, + pecotmr:::.placeholderRanges(1L) + ) + expect_true(empty$regionGiven) + expect_identical(as.character(empty$region), "chr1:1-5000") +}) + +test_that(".refuseUncontainedRegions wants a given range to hold its row", { + pieces <- GenomicRanges::GRangesList( + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 300L), width = 1L) + ), + GenomicRanges::GRanges(), + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 300L), width = 1L) + ) + ) + given <- function(chrom, start, end) { + GenomicRanges::GRanges(chrom, IRanges::IRanges(start, end)) + } + refuse <- function(g, has = c(TRUE, TRUE, FALSE)) { + pecotmr:::.refuseUncontainedRegions(g, has, pieces, "f") + } + # Held; an empty row holds nothing, and a row given no range is not + # checked. + expect_null(refuse(given(c("chr1", "chr9", "chr9"), 50L, 400L))) + expect_error( + refuse(given(c("chr1", "chr1", "chr1"), 150L, 400L)), + "row 1: range chr1:150-400, variants at chr1:100-300", + fixed = TRUE + ) + # Another chromosome holds none of them. + expect_error( + refuse(given(c("chr2", "chr1", "chr1"), 1L, 5000L)), + "variants at chr1:100-300" + ) + # A variant sits at its start, so an indel's width cannot carry it past + # the end of the block it starts in. + indel <- GenomicRanges::GRangesList( + GenomicRanges::GRanges("chr1", IRanges::IRanges(300L, 310L)) + ) + expect_null(pecotmr:::.refuseUncontainedRegions( + given("chr1", 1L, 305L), + TRUE, + indel, + "f" + )) +}) + +test_that(".rowRegions falls back to the span where no range is stored", { + x <- GwasSumStats( + studyName = "s", + entry = list(.ts_gwasVariants()), + genome = "hg19", + region = GenomicRanges::GRanges("chr1:1-5000") + ) + r <- pecotmr:::.rowRegions(x) + expect_identical(as.character(r$region), "chr1:1-5000") + expect_true(r$regionGiven) + # Saved before the columns existed: the span, computed. + old <- x + old$region <- NULL + old$regionGiven <- NULL + r <- pecotmr:::.rowRegions(old) + expect_identical(as.character(r$region), "chr1:100-1000") + expect_false(r$regionGiven) + # A range without its origin is not taken as given. + noOrigin <- x + noOrigin$regionGiven <- NULL + expect_false(pecotmr:::.rowRegions(noOrigin)$regionGiven) + # A placeholder a combine padded in falls back to the span as well. + padded <- x + padded$region <- pecotmr:::.placeholderRanges(1L) + padded$regionGiven <- NA + r <- pecotmr:::.rowRegions(padded) + expect_identical(as.character(r$region), "chr1:100-1000") + expect_false(r$regionGiven) +}) + +test_that(".checkGwasBlockReach words what it finds", { + v <- .ts_gwasVariants() + computed <- GwasSumStats( + studyName = c("s", "s"), + entry = list(v[1:5], v[6:10]), + genome = "hg19", + blockId = c("bA", "bB") + ) + # Two variants before the first block's span count against it. + expect_warning( + pecotmr:::.checkGwasBlockReach( + list(u = .ts_positions(c(10L, 20L, 100L))), + computed, + "f", + "units" + ), + "u: 2 variant(s) past the start of block bA (chr1:100-500) of GWAS", + fixed = TRUE + ) + # Past five lines the rest are counted. + many <- set_names( + rep(list(.ts_positions(c(1000L, 1100L, 1200L))), 7L), + str_c("u", 1:7) + ) + msg <- tryCatch( + pecotmr:::.checkGwasBlockReach(many, computed, "f", "units"), + warning = conditionMessage + ) + expect_match(msg, "u5: 2 variant(s)", fixed = TRUE) + expect_match(msg, "... and 2 more.", fixed = TRUE) + expect_no_match(msg, "u6: ", fixed = TRUE) + # A fine-mapping result's fit is a study and a method, and its given + # window is checked strictly. + fmr <- GwasFineMappingResult( + studyName = "s", + method = "susie", + entry = list(.sc_makeFineMappingRow(3)), + region = GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, 350L)) ) - # 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" + pecotmr:::.checkGwasBlockReach( + list(u = .ts_positions(c(200L, 400L))), + fmr, + "f", + "units" + ), + "u: 1 variant(s) past the end of block chr1_100_300 (chr1:1-350) of", + fixed = TRUE + ) + # Nothing to check against, or with. + expect_null( + pecotmr:::.checkGwasBlockReach(list(), computed, "f", "units") + ) + expect_null( + pecotmr:::.checkGwasBlockReach( + list(u = .ts_positions(100L)), + computed[0L], + "f", + "units" + ) + ) +}) + +# =========================================================================== +# Fit coverage: what a narrowed row's stored fit still describes +# =========================================================================== + +.ts_fitted <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + +# A fine-mapping row whose fit was made on `.ts_fitted`, holding `keep` of +# them. +.ts_fitRow <- function(keep = seq_along(.ts_fitted)) { + pip <- c(0.5, 0.3, 0.2) + full <- FineMappingRow( + .ts_fitted, + list(pip = pip), + data.frame(variant_id = .ts_fitted, pip = pip) + ) + methods::new( + "FineMappingRow", + variants = variants(full)[keep], + susieFit = susieFit(full), + fitVariants = .ts_fitted + ) +} + +# A collection of `n` rows, each fitted on `.ts_fitted` and narrowed to its +# first two. +.ts_narrowedCollection <- function(n) { + pip <- c(0.5, 0.3, 0.2) + row <- FineMappingRow( + .ts_fitted, + list(pip = pip), + data.frame(variant_id = .ts_fitted, pip = pip) + ) + x <- QtlFineMappingResult( + studyName = sprintf("s%d", seq_len(n)), + context = rep("c1", n), + trait = rep("g1", n), + method = rep("susie", n), + entry = rep(list(row), n) + ) + endoapply(x, utils::head, 2L) +} + +test_that(".lostFitVariantCount counts the fit's variants a row lost", { + f <- pecotmr:::.lostFitVariantCount + expect_equal(f(.ts_fitted, .ts_fitted), 0L) + expect_equal(f(.ts_fitted, .ts_fitted[1:2]), 1L) + expect_equal(f(character(0), .ts_fitted), 0L) + # A variant held under its swapped alleles is still held. + expect_equal(f(.ts_fitted, c("chr1:100:G:A", .ts_fitted[2:3])), 0L) +}) + +test_that(".fitColumnOf finds each held variant's column in the fit", { + f <- pecotmr:::.fitColumnOf + expect_equal(f(.ts_fitted[c(3L, 1L)], .ts_fitted), c(3L, 1L)) + # Allele-aware for a swapped id; NA for a variant the fit never had. + expect_equal(f(c("chr1:200:T:C", "chr1:900:A:G"), .ts_fitted), c(2L, NA)) +}) + +test_that(".mdFitVariants reads a group's first row, nothing for old rows", { + md <- S4Vectors::DataFrame( + fitVariants = IRanges::CharacterList(list(c("a", "b"), c("a", "b"))) + ) + # Rows split from one entry repeat its fit and its variants alike. + expect_equal(pecotmr:::.mdFitVariants(md, c(1L, 2L)), c("a", "b")) + expect_equal( + pecotmr:::.mdFitVariants(S4Vectors::DataFrame(x = 1:2), 1L), + character(0) + ) +}) + +test_that(".partsFitIds: the recorded ids, else the fit's, else the row's", { + expect_equal(pecotmr:::.partsFitIds(.ts_fitRow(1:2)), .ts_fitted) + unrecorded <- methods::new( + "FineMappingRow", + variants = variants(.ts_fitRow()), + susieFit = NULL + ) + named <- matrix(0, 1L, 3L, dimnames = list(NULL, rev(.ts_fitted))) + expect_equal(pecotmr:::.partsFitIds(unrecorded, named), rev(.ts_fitted)) + expect_equal(pecotmr:::.partsFitIds(unrecorded), .ts_fitted) +}) + +test_that("a row records fit variants only when it carries a fit", { + w <- c(0.1, 0.2, 0.3) + withCv <- TwasWeightsRow(.ts_fitted, w, cvResult = list(r2 = 0.5)) + expect_equal(pecotmr:::.rowFitVariants(withCv), .ts_fitted) + # Weights alone are no fit payload, and topLoci alone no fit. + expect_equal( + pecotmr:::.rowFitVariants(TwasWeightsRow(.ts_fitted, w)), + character(0) + ) + fitless <- FineMappingRow( + .ts_fitted, + NULL, + data.frame(variant_id = .ts_fitted, pip = c(0.5, 0.3, 0.2)) + ) + expect_equal(pecotmr:::.rowFitVariants(fitless), character(0)) +}) + +test_that(".fitCoverageChecked warns about a narrowed row and returns it", { + narrowed <- .ts_fitRow(1:2) + expect_warning( + out <- pecotmr:::.fitCoverageChecked(narrowed, "f()"), + "f\\(\\): the stored fit was made with 3 variants, 1 of which" + ) + expect_identical(out, narrowed) + cnd <- tryCatch( + pecotmr:::.fitCoverageChecked(narrowed, "f()"), + warning = identity + ) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_no_warning(pecotmr:::.fitCoverageChecked(.ts_fitRow(), "f()")) +}) + +test_that(".fitCoverageCheckedRows names at most five narrowed rows", { + x <- .ts_narrowedCollection(6L) + cnd <- tryCatch( + pecotmr:::.fitCoverageCheckedRows(x, "f()"), + warning = identity + ) + expect_s3_class(cnd, "pecotmrFitCoverage") + msg <- conditionMessage(cnd) + expect_match(msg, "f\\(\\): 6 row\\(s\\) hold fewer variants") + expect_equal(stringr::str_count(msg, "\\|c1\\|g1\\|susie"), 5L) + expect_invisible(suppressWarnings( + pecotmr:::.fitCoverageCheckedRows(x, "f()") + )) +}) + +test_that(".fitCoverageCheckedRows is silent without a record or rows", { + x <- .ts_narrowedCollection(1L) + expect_no_warning(pecotmr:::.fitCoverageCheckedRows(x[0], "f()")) + unrecorded <- x + unrecorded$fitVariants <- NULL + expect_no_warning(pecotmr:::.fitCoverageCheckedRows(unrecorded, "f()")) + # An optional input left out is nothing to check. + expect_no_warning(pecotmr:::.fitCoverageCheckedRows(NULL, "f()")) +}) + +# TWAS weights fitted on `.ts_fitted`, holding `keep` of them. +.ts_weights <- function(keep = seq_along(.ts_fitted)) { + tw <- TwasWeights( + studyName = "w1", + context = "c1", + trait = "g1", + method = "lasso", + entry = list( + TwasWeightsRow(.ts_fitted, c(0.1, 0.2, 0.3), cvResult = list()) + ) + ) + endoapply(tw, `[`, keep) +} + +test_that(".narrowedRowLabels labels the narrowed rows and no others", { + labels <- pecotmr:::.narrowedRowLabels(.ts_narrowedCollection(2L)) + expect_length(labels, 2L) + expect_match(labels, "^s[12]\\|c1\\|g1\\|susie") + expect_identical(pecotmr:::.narrowedRowLabels(.ts_weights()), character(0)) + expect_identical( + pecotmr:::.narrowedRowLabels(.ts_weights(1:2)), + pecotmr:::.pubRowLabels(.ts_weights(1:2), 1L) + ) +}) + +test_that(".fitCoverageCheckedAll names every input's narrowed rows at once", { + fm <- .ts_narrowedCollection(2L) + cnd <- tryCatch( + pecotmr:::.fitCoverageCheckedAll( + list(NULL, fm, .ts_weights(1:2)), + "f()" + ), + warning = identity + ) + expect_s3_class(cnd, "pecotmrFitCoverage") + expect_match(conditionMessage(cnd), "f\\(\\): 3 row\\(s\\) hold fewer") + expect_match(conditionMessage(cnd), "w1\\|c1\\|g1\\|lasso") + expect_null(suppressWarnings( + pecotmr:::.fitCoverageCheckedAll(list(fm), "f()") + )) + expect_no_warning( + pecotmr:::.fitCoverageCheckedAll(list(NULL, .ts_weights()), "f()") + ) + # Anything but a collection is left to its caller's own validation. + expect_identical( + pecotmr:::.narrowedRowLabels(data.frame(a = 1)), + character(0) + ) +}) + +test_that("the joint warning's hint is that of the first narrowed input", { + fm <- .ts_narrowedCollection(1L) + weightsFirst <- tryCatch( + pecotmr:::.fitCoverageCheckedAll(list(.ts_weights(1:2), fm), "f()"), + warning = identity + ) + expect_match(conditionMessage(weightsFirst), "Refit on the variants kept") + expect_false(str_detect( + conditionMessage(weightsFirst), + "intersectVariants" + )) + # An input with nothing narrowed does not choose the hint. + fmFirst <- tryCatch( + pecotmr:::.fitCoverageCheckedAll(list(.ts_weights(), fm), "f()"), + warning = identity + ) + expect_match(conditionMessage(fmFirst), "intersectVariants") +}) + +test_that(".muffleFitCoverage muffles fit-coverage warnings and no others", { + expect_no_warning( + out <- pecotmr:::.muffleFitCoverage({ + warn("narrowed", class = "pecotmrFitCoverage") + "value" + }) + ) + expect_equal(out, "value") + expect_warning(pecotmr:::.muffleFitCoverage(warn("other")), "other") +}) + +test_that("the coverage hint names intersectVariants() only where it applies", { + expect_match( + pecotmr:::.fitCoverageHint(.ts_fitRow()), + "intersectVariants\\(\\) restricts a fit" + ) + expect_match( + pecotmr:::.fitCoverageHint(.ts_narrowedCollection(1L)), + "intersectVariants" + ) + weightsHint <- pecotmr:::.fitCoverageHint( + TwasWeightsRow(.ts_fitted, c(0.1, 0.2, 0.3)) + ) + expect_false(str_detect(weightsHint, "intersectVariants")) + expect_match(weightsHint, "Refit on the variants kept") +}) + +test_that(".naLikeColumn pads a list column with empty entries of its kind", { + cl <- pecotmr:::.naLikeColumn(IRanges::CharacterList("a"), 2L) + expect_s4_class(cl, "CharacterList") + expect_equal(unname(lengths(cl)), c(0L, 0L)) + sl <- pecotmr:::.naLikeColumn(S4Vectors::SimpleList(list(1)), 2L) + expect_s4_class(sl, "SimpleList") + expect_length(sl, 2L) + expect_null(sl[[1L]]) +}) + +test_that("binding a collection saved before fitVariants pads the column", { + x <- .ts_narrowedCollection(2L) + old <- x[1L] + old$fitVariants <- NULL + out <- pecotmr:::.rbindCollections(list(old, x[2L])) + expect_s4_class(out$fitVariants, "CharacterList") + expect_equal(unname(lengths(out$fitVariants)), c(0L, 3L)) +}) + +# =========================================================================== +# .fmrRowTopLoci +# =========================================================================== + +test_that(".fmrRowTopLoci() tables convert to ranges", { + tl <- data.frame( + variant_id = c("1:100:A:G", "1:200:C:T"), + pip = c(0.9, 0.1), + betahat = c(0.5, -0.2), + sebetahat = c(0.1, 0.2), + cs = c(1L, 0L), + method = "susie", + stringsAsFactors = FALSE + ) + ent <- FineMappingRow( + variantIds = tl$variant_id, + susieFit = list(), + topLoci = tl + ) + # .fmrRowTopLoci() is the per-row table; topLoci() converts once, after + # the aggregate view has stacked the rows, so the conversion is tested + # through the converter it now lives in. + out <- .fmrRowTopLoci(ent) + expect_s3_class(out, "data.frame") + gr <- pecotmr:::.variantTableGRanges(out) + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 2) + expect_equal(S4Vectors::mcols(gr)$pip, c(0.9, 0.1)) +}) + +test_that(".fmrRowTopLoci() empty input converts to empty ranges", { + ent <- FineMappingRow( + variantIds = character(0), + susieFit = list(), + topLoci = data.frame() + ) + gr <- pecotmr:::.variantTableGRanges(.fmrRowTopLoci(ent)) + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 0) +}) + +test_that(".fmrRowTopLoci(raw = TRUE) returns the stored table verbatim", { + vids <- paste0("chr1:", 1:4, ":A:G") + entry <- .makeAdjustEntry(vids) + raw <- .fmrRowTopLoci(entry, raw = TRUE) + expect_equal(nrow(raw), length(vids)) + expect_true(all(c("betahat", "sebetahat") %in% names(raw))) + # The default view filters by pip and projects; raw does neither. + expect_false(identical(names(raw), names(.fmrRowTopLoci(entry)))) +}) + +test_that("topLoci surfaces the mvsusie lfsr through the projector", { + tl <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + chrom = "1", + pos = c(100L, 200L), + A1 = c("A", "C"), + A2 = c("G", "T"), + pip = c(0.6, 0.4), + posterior_mean = c(0.1, 0.2), + posterior_sd = c(0.05, 0.05), + cs_95 = c("mvsusie_1", "mvsusie_1"), + lfsr = c(0.001, 0.02), + stringsAsFactors = FALSE + ) + e <- FineMappingRow( + variantIds = tl$variant_id, + susieFit = list(pip = tl$pip), + topLoci = tl ) + out <- .fmrRowTopLoci(e, signalCutoff = 0) + expect_true(is_in("lfsr", names(out))) + expect_equal(out$lfsr, c(0.001, 0.02)) }) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index dc0ef350..0c11cbd6 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -1,5 +1,18 @@ context("twasWeights") +.sc_makeTwasWeightsRow <- function( + p = 5L, + weightStandardized = FALSE, + weightsDataType = "expression" +) { + TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), + weights = rnorm(p), + weightStandardized = weightStandardized, + weightsDataType = weightsDataType + ) +} + # --------------------------------------------------------------------------- # Shared synthetic data generator # --------------------------------------------------------------------------- @@ -87,7 +100,7 @@ mockSusie <- function(...) { # =========================================================================== # -# .twas_method_lookup +# .twasMethodLookup # # =========================================================================== @@ -127,26 +140,8 @@ generateXY <- function( return(list(X = X, Y = y)) } -test_that(".twas_method_lookup: 'default' preset returns 10 methods", { - result <- pecotmr:::.twasMethodLookup("default") - expected_names <- c( - "susie_weights", - "susie_inf_weights", - "mrash_weights", - "enet_weights", - "lasso_weights", - "mcp_weights", - "scad_weights", - "l0learn_weights", - "bayes_r_weights", - "bayes_c_weights" - ) - expect_equal(sort(names(result)), sort(expected_names)) -}) - -test_that(".twas_method_lookup: 'fast_default' preset returns 8 methods", { - result <- pecotmr:::.twasMethodLookup("fastDefault") - expected_names <- c( +test_that(".twasMethodLookup: 'default' (10) and 'fastDefault' (8) presets", { + fastDefault <- c( "susie_weights", "susie_inf_weights", "mrash_weights", @@ -156,10 +151,20 @@ test_that(".twas_method_lookup: 'fast_default' preset returns 8 methods", { "scad_weights", "l0learn_weights" ) - expect_equal(sort(names(result)), sort(expected_names)) + presets <- list( + default = c(fastDefault, "bayes_r_weights", "bayes_c_weights"), + fastDefault = fastDefault + ) + for (preset in names(presets)) { + expect_equal( + sort(names(pecotmr:::.twasMethodLookup(preset))), + sort(presets[[preset]]), + info = preset + ) + } }) -test_that(".twas_method_lookup: custom vector of short names", { +test_that(".twasMethodLookup: custom vector of short names", { result <- pecotmr:::.twasMethodLookup(c("susie", "enet", "dprVb")) expect_equal( sort(names(result)), @@ -167,30 +172,31 @@ test_that(".twas_method_lookup: custom vector of short names", { ) }) -test_that(".twas_method_lookup: unknown method produces error", { +test_that(".twasMethodLookup: unknown method produces error", { expect_error( pecotmr:::.twasMethodLookup(c("susie", "nonexistent_method")), "unknown method token" ) }) -test_that(".twas_method_lookup: default args are set for mrash, not susie", { +test_that(".twasMethodLookup: default args are set for mrash, not susie", { result <- pecotmr:::.twasMethodLookup("fastDefault") # susie carries NO fitting defaults: susieWeights extracts from a supplied - # fit and never runs susie, so `refine` / `L` would have nothing to configure. + # fit and never runs susie, so `refine` / `L` would have nothing to + # configure. expect_length(result$susie_weights, 0L) # 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) }) -test_that(".twas_method_lookup: methods with no special args get empty list", { +test_that(".twasMethodLookup: methods with no special args get empty list", { result <- pecotmr:::.twasMethodLookup(c("enet", "lasso")) expect_equal(length(result$enet_weights), 0L) expect_equal(length(result$lasso_weights), 0L) }) -test_that(".twas_method_lookup: all DPR variants can coexist", { +test_that(".twasMethodLookup: all DPR variants can coexist", { result <- pecotmr:::.twasMethodLookup(c( "dprVb", "dprGibbs", @@ -212,18 +218,6 @@ test_that(".twas_method_lookup: all DPR variants can coexist", { # # =========================================================================== -test_that("twasPredict: basic matrix multiplication is correct", { - d <- makeData(n = 20, p = 5) - set.seed(99) - w <- matrix(runif(5), ncol = 1) - rownames(w) <- colnames(d$X) - wl <- list(test_weights = w) - res <- twasPredict(d$X, wl) - - expected <- d$X %*% w - expect_equal(res[["test_predicted"]], expected) -}) - test_that("twasPredict: multiple weight methods in list", { d <- makeData(n = 20, p = 5) w1 <- matrix(c(1, 0, 0, 0, 0), ncol = 1) @@ -237,22 +231,6 @@ test_that("twasPredict: multiple weight methods in list", { expect_equal(res[["method_b_predicted"]], d$X %*% w2) }) -test_that("twasPredict: name transformation weights -> predicted", { - set.seed(42) - wl <- list( - lassoWeights = matrix(1, nrow = 3, ncol = 1), - enetWeights = matrix(1, nrow = 3, ncol = 1), - susieWeights = matrix(1, nrow = 3, ncol = 1) - ) - X <- matrix(rnorm(9), nrow = 3, ncol = 3) - res <- twasPredict(X, wl) - - expect_equal( - names(res), - c("lassoPredicted", "enetPredicted", "susiePredicted") - ) -}) - test_that("twasPredict: names without _weights suffix are kept unchanged", { wl <- list(custom_method = matrix(1, nrow = 2, ncol = 1)) X <- matrix(1:4, nrow = 2, ncol = 2) @@ -262,17 +240,6 @@ test_that("twasPredict: names without _weights suffix are kept unchanged", { expect_equal(names(res), "custom_method") }) -test_that("twasPredict: single column Y dimension preserved", { - d <- makeData(n = 10, p = 4) - w <- matrix(rep(0.25, 4), ncol = 1) - wl <- list(avg_weights = w) - res <- twasPredict(d$X, wl) - - expect_true(is.matrix(res[["avg_predicted"]])) - expect_equal(nrow(res[["avg_predicted"]]), 10) - expect_equal(ncol(res[["avg_predicted"]]), 1) -}) - test_that("twasPredict: multi-column weights produce multi-column predictions", { set.seed(42) n <- 15 @@ -286,20 +253,13 @@ test_that("twasPredict: multi-column weights produce multi-column predictions", expect_equal(res[["multi_predicted"]], X %*% W) }) -test_that("twasPredict: zero weights give zero predictions", { - X <- matrix(1:6, nrow = 2, ncol = 3) - wl <- list(null_weights = matrix(0, nrow = 3, ncol = 1)) - res <- twasPredict(X, wl) - expect_true(all(res[["null_predicted"]] == 0)) -}) - # =========================================================================== # -# twasWeights (input validation and basic behavior) +# learnTwasWeights (input validation and basic behavior) # # =========================================================================== -test_that("twasWeights: X must be a matrix", { +test_that("learnTwasWeights: X must be a matrix", { d <- makeData() expect_error( learnTwasWeights(as.data.frame(d$X), d$Y, weightMethods = list()), @@ -307,7 +267,7 @@ test_that("twasWeights: X must be a matrix", { ) }) -test_that("twasWeights: Y must be a matrix or vector", { +test_that("learnTwasWeights: Y must be a matrix or vector", { d <- makeData() # In R, is.vector(list(...)) returns TRUE, so a list passes the initial # type check and gets converted via matrix(). The resulting matrix has @@ -318,7 +278,7 @@ test_that("twasWeights: Y must be a matrix or vector", { ) }) -test_that("twasWeights: Y as vector gets converted to matrix internally", { +test_that("learnTwasWeights: Y as vector gets converted to matrix internally", { d <- makeData() y_vec <- as.numeric(d$Y) @@ -341,7 +301,7 @@ test_that("twasWeights: Y as vector gets converted to matrix internally", { expect_true(all(is.finite(w))) }) -test_that("twasWeights: mismatched row counts error", { +test_that("learnTwasWeights: mismatched row counts error", { d <- makeData(n = 50, p = 10) Y_short <- d$Y[1:30, , drop = FALSE] expect_error( @@ -350,18 +310,18 @@ test_that("twasWeights: mismatched row counts error", { ) }) -test_that("twasWeights: character weight_methods input is accepted", { +test_that("learnTwasWeights: character weightMethods input is accepted", { d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0, ncol(X)) ) - # Short name should be resolved via .twas_method_lookup + # Short name should be resolved via .twasMethodLookup result <- learnTwasWeights(d$X, d$Y, weightMethods = c("lasso")) expect_true(is(result, "TwasWeights")) expect_equal(methodNames(result), "lasso") }) -test_that("twasWeights: zero variance columns are filtered and padded back with zeros", { +test_that("learnTwasWeights: zero-variance columns are filtered, weighted 0", { d <- makeData(n = 50, p = 10, add_zero_var_col = TRUE) p_with_extra <- ncol(d$X) # 11 columns, last is zero-var @@ -378,7 +338,8 @@ test_that("twasWeights: zero variance columns are filtered and padded back with weightMethods = list(lasso_weights = list()) ) - # The returned weight matrix should have rows equal to total columns (including zero-var) + # The returned weight matrix should have rows equal to total columns + # (including zero-var) expect_equal(nrow(.weightsByMethod(result, "lassoWeights")), p_with_extra) # The zero-var column weight should be 0 (padded back) expect_equal( @@ -387,7 +348,7 @@ test_that("twasWeights: zero variance columns are filtered and padded back with ) }) -test_that("twasWeights: rownames of result match colnames of X", { +test_that("learnTwasWeights: weights are ncol(X) x ncol(Y), rows named by X", { d <- makeData() local_mocked_bindings( enetWeights = function(X, y, ...) rep(0.1, ncol(X)) @@ -397,29 +358,17 @@ test_that("twasWeights: rownames of result match colnames of X", { d$Y, weightMethods = list(enetWeights = list()) ) - expect_equal( - rownames(.weightsByMethod(result, "enetWeights")), - colnames(d$X) - ) -}) - -test_that("twasWeights: result dimensions match ncol(X) x ncol(Y)", { - d <- makeData() - local_mocked_bindings( - enetWeights = function(X, y, ...) rep(0, ncol(X)) - ) - result <- learnTwasWeights( - d$X, - d$Y, - weightMethods = list(enetWeights = list()) - ) expect_equal( dim(.weightsByMethod(result, "enetWeights")), c(ncol(d$X), ncol(d$Y)) ) + expect_equal( + rownames(.weightsByMethod(result, "enetWeights")), + colnames(d$X) + ) }) -test_that("twasWeights: multiple methods return named list with one entry per method", { +test_that("learnTwasWeights: multiple methods return one entry per method", { d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0.1, ncol(X)), @@ -437,39 +386,28 @@ test_that("twasWeights: multiple methods return named list with one entry per me # =========================================================================== # -# twasWeights with actual glmnet (lasso/enet) -- skip if not available +# learnTwasWeights with real glmnet (lasso/enet) # # =========================================================================== -test_that("twasWeights: lassoWeights produces correct structure with real glmnet", { +test_that("learnTwasWeights: lasso and enet fit p x 1 weights with glmnet", { skip_if_not_installed("glmnet") d <- makeData(n = 50, p = 10) - result <- learnTwasWeights( - d$X, - d$Y, - weightMethods = list(lasso_weights = list()) - ) - - expect_true(is(result, "TwasWeights")) - expect_equal(methodNames(result), "lasso") - expect_equal(nrow(.weightsByMethod(result, "lassoWeights")), ncol(d$X)) - expect_equal(ncol(.weightsByMethod(result, "lassoWeights")), 1) - # At least some weights should be non-zero for this strong signal - expect_true(any(.weightsByMethod(result, "lassoWeights") != 0)) -}) - -test_that("twasWeights: enetWeights produces correct structure with real glmnet", { - skip_if_not_installed("glmnet") - d <- makeData(n = 50, p = 10) - result <- learnTwasWeights( - d$X, - d$Y, - weightMethods = list(enetWeights = list()) - ) - - expect_true(is(result, "TwasWeights")) - expect_equal(methodNames(result), "enet") - expect_equal(nrow(.weightsByMethod(result, "enetWeights")), ncol(d$X)) + # One snake_case and one camelCase key: both spellings resolve. + keys <- c(lasso = "lasso_weights", enet = "enetWeights") + for (method in names(keys)) { + result <- learnTwasWeights( + d$X, + d$Y, + weightMethods = set_names(list(list()), keys[[method]]) + ) + w <- .weightsByMethod(result, method) + expect_true(is(result, "TwasWeights"), info = method) + expect_equal(methodNames(result), method, info = method) + expect_equal(dim(w), c(ncol(d$X), 1L), info = method) + # At least some weights should be non-zero for this strong signal + expect_true(any(w != 0), info = method) + } }) # =========================================================================== @@ -478,18 +416,13 @@ test_that("twasWeights: enetWeights produces correct structure with real glmnet" # # =========================================================================== -test_that("twasWeightsCv: NULL weight_methods returns only samplePartition", { - d <- makeData() - result <- twasWeightsCv(d$X, d$Y, fold = 3, weightMethods = NULL) - expect_equal(names(result), "samplePartition") - expect_true(is.data.frame(result$samplePartition)) -}) - -test_that("twasWeightsCv: samplePartition structure is correct", { +test_that("twasWeightsCv: NULL methods return only a well-formed partition", { d <- makeData() result <- twasWeightsCv(d$X, d$Y, fold = 5, weightMethods = NULL) + expect_equal(names(result), "samplePartition") sp <- result$samplePartition + expect_true(is.data.frame(sp)) expect_true("Sample" %in% colnames(sp)) expect_true("Fold" %in% colnames(sp)) expect_equal(nrow(sp), nrow(d$X)) @@ -498,7 +431,7 @@ test_that("twasWeightsCv: samplePartition structure is correct", { expect_true(all(rownames(d$X) %in% sp$Sample)) }) -test_that("twasWeightsCv: character weight_methods are accepted", { +test_that("twasWeightsCv: character weightMethods are accepted", { d <- makeData() local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0, ncol(X)) @@ -619,29 +552,10 @@ test_that("twasWeightsCv: multivariate Y with multiple columns", { # =========================================================================== # -# twasWeightsPipeline (structure and input validation) +# learnTwasWeights with supplied SuSiE fits; twasWeightsCv plumbing # # =========================================================================== -test_that("learnTwasWeights refuses the susie + susieInf pair without fits", { - # The chained susieInf -> susie fit lives in fineMappingPipeline() now; - # learnTwasWeights never fine-maps, so the pair is an error here. - # fitSusieInfThenSusie() itself is covered in test_fineMappingWrappers.R. - d <- makeData(n = 50, p = 10) - expect_error( - learnTwasWeights( - d$X, - as.numeric(d$Y), - weightMethods = list( - susie_weights = list(), - susie_inf_weights = list() - ) - ), - "susie, susieInf" - ) -}) - - test_that("learnTwasWeights resolves fits under camelCase method names", { # `susieWeights` and `susie_weights` name the same method; a fit supplied # for one spelling must land on the other's arguments too. @@ -768,14 +682,10 @@ test_that("twasWeightsCv: dataDrivenPriorMatricesCv is plumbed through", { }) # =========================================================================== -# twasWeightsPipeline: removed_methods warning + max_cv_variants subsampling +# learnTwasWeights: a fit with extra rows is cut back to the fitted variants # =========================================================================== -# =========================================================================== -# twasWeights: dim-fix branch when nrow(weights_matrix) != length(valid_columns) -# =========================================================================== - -test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns when row counts mismatch", { +test_that("learnTwasWeights: mr.mash rows beyond X's variants are dropped", { set.seed(42) n <- 20 p <- 5 @@ -787,8 +697,8 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns local_mocked_bindings( mrmashWeights = function(X, Y, ...) { - # Return more rows than valid_columns (length p) so the dim-fix branch - # subsets the matrix back to names(valid_columns). + # Return more rows than the p fitted variants, so the result is + # subset back to those variants' names. extra_rows <- p + 2 m <- matrix( seq_len(extra_rows * ncol(Y)), @@ -809,7 +719,7 @@ test_that("twasWeights: multivariate weights_matrix is reduced to valid_columns Y, weightMethods = list(mrmashWeights = list()) ) - # After the dim-fix, the weights matrix is restricted to v1..v5 -> shape p x ncol(Y) + # Restricted to the p fitted variants -> shape p x ncol(Y) expect_equal(nrow(.weightsByMethod(result, "mrmashWeights")), p) expect_equal(ncol(.weightsByMethod(result, "mrmashWeights")), 2) expect_equal( @@ -855,11 +765,7 @@ test_that("twasWeightsCv handles errors appropriately", { sim <- generateXY(seed = 1) X <- sim$X y <- sim$Y - local_mocked_bindings( - susieWeights = function(X, y, ...) rnorm(ncol(X)), - glmnetWeights = function(X, y, ...) runif(ncol(X)) - ) - weight_methods_test <- list(susie = list(), glmnetWeights = list()) + # fold defaults to NULL, so this is also the call that omits it. expect_error(twasWeightsCv(X, y, fold = NULL), "fold.*samplePartitions") expect_error( twasWeightsCv(X, y, fold = "invalid"), @@ -868,39 +774,19 @@ test_that("twasWeightsCv handles errors appropriately", { expect_error(twasWeightsCv(X, y, fold = -1), "Must be >= 1") expect_error(twasWeightsCv(2, y, fold = 2), "Must be of type 'matrix'") expect_error(twasWeightsCv(X, 2, fold = 2), "Y.*Must have exactly 10 rows") - expect_error( - twasWeightsCv( - matrix(rnorm(4, nrow = 2)), - matrix(rnorm(2, nrow = 1)), - fold = 2 - ), - "unused argument" - ) - expect_error(twasWeightsCv(X, y), "fold.*samplePartitions") }) test_that("learnTwasWeights handles errors appropriately", { sim <- generateXY(seed = 1) - X <- sim$X - y <- sim$Y - local_mocked_bindings( - susieWeights = function(X, y, ...) rnorm(ncol(X)), - glmnetWeights = function(X, y, ...) runif(ncol(X)) - ) - weight_methods_test <- list(susie = list(), glmnetWeights = list()) expect_error( - learnTwasWeights( - matrix(rnorm(4, nrow = 2)), - matrix(rnorm(2, nrow = 1)) - ), + learnTwasWeights(sim$X, sim$Y), "weightMethods.*is missing" ) - expect_error(learnTwasWeights(X, y), "weightMethods") }) # =========================================================================== -# twasZ: mathematical correctness (single-method / vector path) +# twasPredict: vector weights # =========================================================================== test_that("twasPredict multiplies X by weights", { @@ -933,14 +819,6 @@ test_that("twasPredict handles multiple weight methods", { }) -test_that("twasPredict with zero weights gives zero predictions", { - X <- matrix(1:6, nrow = 2, ncol = 3) - weights_list <- list(null_weights = c(0, 0, 0)) - result <- twasPredict(X, weights_list) - expect_true(all(result$null_predicted == 0)) -}) - - test_that("twasPredict with single variant", { X <- matrix(c(1, 2, 3), nrow = 3, ncol = 1) weights_list <- list(single_weights = 2.0) @@ -976,6 +854,7 @@ test_that("TwasWeights: studyName / contexts / traitNames / methodNames", { method = c("lasso", "lasso"), entry = list(e, e) ) + expect_setequal(studyName(tw), c("s1", "s2")) expect_setequal(contexts(tw), c("c1", "c2")) expect_equal(traitNames(tw), "t1") expect_equal(methodNames(tw), "lasso") @@ -1050,9 +929,46 @@ test_that("TwasWeights: twasWeights extracts the entry for a tuple", { expect_equal(unname(weights(picked)), unname(weights(e2))) }) -# =========================================================================== -# LdData -# =========================================================================== +test_that("TwasWeights: rows are picked by window through subsetting", { + near <- TwasWeightsRow( + variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), + weights = c(0.1, 0.2, 0.3, 0.4) + ) + far <- TwasWeightsRow( + variantIds = sprintf("chr2:%d:A:G", 100L * (1:4)), + weights = c(0.5, 0.6, 0.7, 0.8) + ) + tw <- TwasWeights( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("t1", "t2"), + method = c("lasso", "lasso"), + entry = list(near, far) + ) + # A window selects rows by subsetting the collection on its rows' + # analysis windows; the one row left needs no other selector. + inChr2 <- tw[IRanges::overlapsAny( + genomicRegion(tw), + GenomicRanges::GRanges("chr2:150-250") + )] + expect_identical(as.character(twasWeights(inChr2)$trait), "t2") + expect_equal(resolveWeights(inChr2)$weights, c(0.5, 0.6, 0.7, 0.8)) + inChr1 <- tw[IRanges::overlapsAny( + genomicRegion(tw), + GenomicRanges::GRanges("chr1:1-1000") + )] + expect_equal(unname(weights(inChr1)), c(0.1, 0.2, 0.3, 0.4)) + expect_identical( + variantIds(inChr1), + sprintf("chr1:%d:A:G", 100L * (1:4)) + ) + # A window over both rows still needs the tuple to choose between them. + both <- tw[IRanges::overlapsAny( + genomicRegion(tw), + GenomicRanges::GRanges(c("chr1:1-1000", "chr2:1-1000")) + )] + expect_error(twasWeights(both), "has 2 entries") +}) # === Tests migrated from test_showMethods.R (TwasWeights) === @@ -1256,13 +1172,13 @@ test_that("TwasWeights: joint* column length must match study", { }) test_that("TwasWeights: weightStandardized/weightsDataType/variantIds delegate to the entry", { - e1 <- twasWeightsRow( + e1 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4), weightStandardized = TRUE, weightsDataType = "expression" ) - e2 <- twasWeightsRow( + e2 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4), weightStandardized = FALSE, @@ -1312,27 +1228,15 @@ test_that("TwasWeights: weightStandardized/weightsDataType/variantIds delegate t ) }) -test_that("TwasWeights: studyName returns unique study labels", { - e <- .sc_makeTwasWeightsRow() - tw <- TwasWeights( - studyName = c("s1", "s2"), - context = c("c1", "c2"), - trait = c("t1", "t1"), - method = c("lasso", "lasso"), - entry = list(e, e) - ) - expect_setequal(studyName(tw), c("s1", "s2")) -}) - test_that("TwasWeights: per-tuple weights/cvResult/methodFits/ldReference", { w1 <- rnorm(4) - e1 <- twasWeightsRow( + e1 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = w1, methodFits = list(tag = "fitA"), cvResult = list(rsq = 0.42) ) - e2 <- twasWeightsRow( + e2 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), weights = rnorm(4) ) @@ -1375,7 +1279,37 @@ test_that("TwasWeights: per-tuple weights/cvResult/methodFits/ldReference", { )$tag, "fitA" ) - expect_s4_class(ldReference(tw), "RangedSummarizedExperiment") + expect_length(ldReference(tw), 1L) + expect_s4_class(ldReference(tw)[[1L]], "RangedSummarizedExperiment") +}) + +test_that("TwasWeights: rejects non-TwasWeightsRow rows", { + expect_error( + TwasWeights( + studyName = "s1", + context = "c1", + trait = "t1", + method = "lasso", + entry = list("not_an_entry") + ), + "must be a TWAS-weight row" + ) +}) + +test_that("TwasWeights: validity does not recurse on key subset (#546)", { + # Building the tuple-uniqueness key via `object[, keyCols]` preserves the + # TwasWeights class while dropping the required `entry` column; older + # S4Vectors revalidates that intermediate and fails with "missing columns". + e <- .sc_makeTwasWeightsRow(p = 5L) + res <- TwasWeights( + studyName = "s1", + context = "c1", + trait = "t1", + method = "lasso", + entry = list(e) + ) + expect_s4_class(res, "TwasWeights") + expect_true(validObject(res)) }) # =========================================================================== @@ -1426,7 +1360,7 @@ test_that(".prepareSusieWeightMethods writes supplied fits onto the method args" test_that("twasWeightsCv: warns when no random seed has been set", { d <- makeData(n = 20, p = 5) # makeData() set a seed; drop it just before the call so the unset-seed - # branch (verbose>=1) is exercised. The fold-sampling at line ~713 restores + # branch (verbose>=1) is exercised. The fold sampling creates a fresh # .Random.seed afterwards, so later tests are unaffected. if (exists(".Random.seed", envir = .GlobalEnv)) { rm(".Random.seed", envir = .GlobalEnv) @@ -1622,7 +1556,8 @@ test_that("learnTwasWeights: univariate fitter runs under verbose=2", { expect_equal(nrow(.weightsByMethod(result, "lassoWeights")), ncol(d$X)) }) -test_that("learnTwasWeights: parallel weights path (numThreads = 2)", { +test_that("learnTwasWeights: parallel weights path (two workers)", { + skip_on_os("windows") d <- makeData(n = 30, p = 6) local_mocked_bindings( lassoWeights = function(X, y, ...) rep(0.1, ncol(X)), @@ -1632,7 +1567,7 @@ test_that("learnTwasWeights: parallel weights path (numThreads = 2)", { d$X, d$Y, weightMethods = list(lasso_weights = list(), enetWeights = list()), - numThreads = 2 + BPPARAM = BiocParallel::MulticoreParam(2) )) expect_true(is(result, "TwasWeights")) expect_setequal(methodNames(result), c("lasso", "enet")) @@ -1649,11 +1584,11 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { p <- 5 w1 <- rnorm(p) w2 <- rnorm(p) - e1 <- twasWeightsRow( + e1 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w1 ) - e2 <- twasWeightsRow( + e2 <- TwasWeightsRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(p)), weights = w2 ) @@ -1789,8 +1724,8 @@ test_that("twasWeightsCv: argument guards fire", { "maxNumVariants.*is not >= 1" ) expect_error( - exec(twasWeightsCv, !!!list_modify(base, !!!list(numThreads = 1.5))), - "numThreads.*Must be of type 'single integerish value'" + exec(twasWeightsCv, !!!list_modify(base, !!!list(BPPARAM = 2))), + "must be a BiocParallelParam" ) expect_error( exec( @@ -1859,55 +1794,8 @@ test_that("twasPredict: weightsList must be a list or TwasWeights", { # fineMappingPipeline's own CV retained each fold's fit. # --------------------------------------------------------------------------- -.twcv_foldFits <- function(seed = 11, fold = 3) { - set.seed(seed) - data(eqtlRegionExample) - X <- eqtlRegionExample$X[, 1:40] - y <- eqtlRegionExample$yRes - Y <- matrix(y, ncol = 1, dimnames = list(rownames(X), "t1")) - cv <- pecotmr:::.fmWeightsCv( - X, - Y, - tokens = "susie", - methodArgs = list(), - fold = fold, - verbose = 0, - seed = 1 - ) - list(X = X, Y = Y, cv = cv, slice = pecotmr:::.fmSliceCv(cv, "susie")) -} - -test_that("fineMappingPipeline CV retains a lean per-fold fit", { - skip_if_not_installed("susieR") - f <- suppressMessages(.twcv_foldFits()) - expect_false(is.null(f$cv$foldFits)) - expect_equal(names(f$cv$foldFits), c("fold_1", "fold_2", "fold_3")) - # lean: only the fields the weight extractors read - fit1 <- f$cv$foldFits[["fold_1"]][["susie"]] - expect_true(all(c("pip", "alpha", "mu") %in% names(fit1))) - expect_false("lbf_variable" %in% names(fit1)) - # and it slices per method onto the row payload - expect_equal(names(f$slice$foldFits), c("fold_1", "fold_2", "fold_3")) -}) - -test_that("twasWeightsCv cannot cross-validate susie without the fold fits", { - skip_if_not_installed("susieR") - f <- suppressMessages(.twcv_foldFits()) - expect_error( - suppressMessages(twasWeightsCv( - f$X, - f$Y, - samplePartitions = f$slice$samplePartition, - weightMethods = list(susie_weights = list()), - verbose = 0 - )), - "never run fine-mapping themselves" - ) -}) - test_that("twasWeightsCv cross-validates susie from the retained fold fits", { - skip_if_not_installed("susieR") - f <- suppressMessages(.twcv_foldFits()) + f <- .twcvFixture out <- suppressMessages(twasWeightsCv( f$X, f$Y, @@ -1920,20 +1808,22 @@ test_that("twasWeightsCv cross-validates susie from the retained fold fits", { expect_false(is.null(out$prediction)) }) -test_that(".twasFoldFit injects the fold's fit under the adapter's fit arg", { +test_that(".twasFoldFit injects the fold's fit, else leaves the args alone", { + f <- pecotmr:::.twasFoldFit ff <- list(susie = list(fold_1 = "FIT1", fold_2 = "FIT2")) - a <- pecotmr:::.twasFoldFit(list(), "susie_weights", 2L, ff) + a <- f(list(), "susie_weights", 2L, ff) expect_identical(a$susieFit, "FIT2") - # a method with no fine-mapping adapter is untouched - b <- pecotmr:::.twasFoldFit(list(), "lasso_weights", 1L, ff) - expect_length(b, 0L) - # and so is the NULL case - expect_length(pecotmr:::.twasFoldFit(list(), "susie_weights", 1L, NULL), 0L) + args <- list(X = 1) + # No CV payload at all. + expect_identical(f(args, "susie_weights", 1L, NULL), args) + # A method with no fine-mapping adapter is untouched. + expect_identical(f(args, "lasso_weights", 1L, ff), args) + # The token is present but carries no folds, so there is nothing to add. + expect_identical(f(args, "susie", 1L, list(susie = list())), args) }) test_that("twasWeightsCv refuses fold fits from a different partition", { - skip_if_not_installed("susieR") - f <- suppressMessages(.twcv_foldFits()) + f <- .twcvFixture wm <- list(susie = list()) # (a) no partition at all: a freshly drawn one would score each fold with @@ -1950,8 +1840,8 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { ) # (b) fits with no fingerprint cannot be shown to match. - unstamped <- f$slice$foldFits - attr(unstamped, "partitionKey") <- NULL + unkeyed <- f$slice$foldFits + attr(unkeyed, "partitionKey") <- NULL expect_error( suppressMessages(twasWeightsCv( f$X, @@ -1959,21 +1849,15 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { weightMethods = wm, verbose = 0, samplePartitions = f$slice$samplePartition, - fittedModelsCv = list(susie = unstamped) + fittedModelsCv = list(susie = unkeyed) )), "no partition fingerprint" ) - # (c) a genuinely different split is caught by the fingerprint. - other <- suppressMessages(pecotmr:::.fmWeightsCv( - f$X, - f$Y, - tokens = "susie", - methodArgs = list(), - fold = 3, - verbose = 0, - seed = 77 - )) + # (c) a genuinely different split is caught by the fingerprint. Drawing + # one needs no fits: with no methods, twasWeightsCv returns just the + # partition. + other <- suppressMessages(twasWeightsCv(f$X, f$Y, fold = 3, seed = 77)) expect_error( suppressMessages(twasWeightsCv( f$X, @@ -1987,21 +1871,6 @@ test_that("twasWeightsCv refuses fold fits from a different partition", { ) }) -test_that(".cvPartitionKey ignores row order but not fold assignment", { - sp <- data.frame(Sample = c("s1", "s2", "s3"), Fold = c(1L, 2L, 1L)) - shuffled <- sp[c(3, 1, 2), ] - expect_identical( - pecotmr:::.cvPartitionKey(sp), - pecotmr:::.cvPartitionKey(shuffled) - ) - moved <- sp - moved$Fold <- c(1L, 1L, 2L) - expect_false(identical( - pecotmr:::.cvPartitionKey(sp), - pecotmr:::.cvPartitionKey(moved) - )) -}) - # --------------------------------------------------------------------------- # Up-front gate: a SuSiE-family method without its fit is refused before any # fitting work, rather than surfacing from inside the per-fold map. @@ -2026,6 +1895,21 @@ test_that("learnTwasWeights refuses a susie token with no fit", { )), "never run fine-mapping themselves" ) + # The susie + susieInf pair is refused too, naming both: the chained + # susieInf -> susie fit lives in fineMappingPipeline(), and + # fitSusieInfThenSusie() itself is covered in test_fineMappingWrappers.R. + expect_error( + learnTwasWeights( + X, + Y, + weightMethods = list( + susie_weights = list(), + susie_inf_weights = list() + ), + verbose = 0 + ), + "susie, susieInf" + ) # supplying it through fittedModels satisfies the gate fit <- suppressMessages(susieR::susie(X, Y[, 1], L = 5)) expect_no_error(suppressMessages(learnTwasWeights( @@ -2045,8 +1929,7 @@ test_that("learnTwasWeights refuses a susie token with no fit", { }) test_that("twasWeightsCv refuses a susie token with no per-fold fits", { - skip_if_not_installed("susieR") - f <- suppressMessages(.twcv_foldFits()) + f <- .twcvFixture expect_error( suppressMessages(twasWeightsCv( f$X, @@ -2055,7 +1938,7 @@ test_that("twasWeightsCv refuses a susie token with no per-fold fits", { weightMethods = list(susie_weights = list()), verbose = 0 )), - "needs that fold's own fit" + "never run fine-mapping themselves.*needs that fold's own fit" ) }) @@ -2074,11 +1957,6 @@ test_that(".twasSusieTokensRequested matches both method spellings", { ) }) -test_that("the twas lookup helpers answer NULL when the token is absent", { - expect_null(pecotmr:::.twasMethodArgsFor(list(), "susie")) - expect_null(pecotmr:::.twasFoldFitsFor(NULL, "susie")) -}) - # --- per-token argument chains ---------------------------------------------- # # The recorded chains in .twasMethodChains() are the basis for checking a @@ -2104,7 +1982,6 @@ test_that("the twas lookup helpers answer NULL when the token is absent", { "penalizedRss", ".penalizedRssPath", "lassosumRss", - ".lassosumRssPath", "sdpr", ".sdprRun", "prsCs", @@ -2196,7 +2073,13 @@ test_that("the recorded RSS chains match what a fit enters", { 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)) + expect_true(is_in(".penalizedRssPath", seen)) + seen <- .tw_traceChain(enetRssWeights(fx$stat, fx$ldReference)) + expect_true(all(is_in(seen, recordedFor("enet")))) + expect_true(is_in(".penalizedRssPath", seen)) + seen <- .tw_traceChain(ridgeRssWeights(fx$stat, fx$ldReference)) + expect_true(all(is_in(seen, recordedFor("ridge")))) + expect_true(is_in(".penalizedRssPath", seen)) prsCsOpts <- PrsCsOptions(nIter = 20, nBurnin = 5, thin = 1) seen <- .tw_traceChain( prsCsWeights(fx$stat, fx$ldReference, methodArgs = prsCsOpts) @@ -2211,11 +2094,44 @@ test_that("the recorded RSS chains match what a fit enters", { expect_true(is_in(".sdprRun", recordedFor("dprGibbs"))) }) +test_that("an RSS method accepts its own penalty settings and no other's", { + # The penalty reaches .penalizedRssPath() as the wrapper's record, so + # every chain shares that hop without taking each other's settings. + accepted <- function(tk) pecotmr:::.twasChainAccepted(tk, "QtlSumStats") + path <- c("lambda", "thr", "maxiter") + l0Only <- c("lambda0", "lambda2", "maxSwaps") + expect_true(all(is_in(path, accepted("lasso")))) + expect_false(any(is_in( + c("alpha", "gamma", "penalty", l0Only, "spec", "label", "method"), + accepted("lasso") + ))) + expect_true(all(is_in(c("alpha", path), accepted("enet")))) + expect_false(any(is_in(c("gamma", l0Only), accepted("enet")))) + expect_false(any(is_in(c("alpha", "gamma", l0Only), accepted("ridge")))) + expect_true(all(is_in(c("alpha", "gamma"), accepted("scad")))) + expect_false(any(is_in(l0Only, accepted("scad")))) + expect_true(all(is_in( + c("penalty", "lambda", l0Only), + accepted("l0learn") + ))) + expect_false(any(is_in(c("alpha", "gamma"), accepted("l0learn")))) +}) + test_that("every RSS chain yields a checkable argument set", { # The point of the chains: each summary-statistics path ends in one of # pecotmr's own solvers, which enumerate their formals, so the RSS side # is checkable even where the individual side is not. - for (tk in c("scad", "mcp", "l0learn", "lasso", "prsCs", "dprGibbs")) { + tokens <- c( + "scad", + "mcp", + "l0learn", + "lasso", + "enet", + "ridge", + "prsCs", + "dprGibbs" + ) + for (tk in tokens) { expect_false( is.null(pecotmr:::.twasChainAccepted(tk, "QtlSumStats")), label = paste("accepted set for", tk) @@ -2255,6 +2171,24 @@ test_that("per-class checking rejects a name only the other path accepts", { ) }) +# The exported *Options constructor that method `token` resolves to on input +# path `path`, by name: NA when the method does not run on that path, "?" +# when what it resolves to is not an exported *Options constructor. +optionsCtorName <- function(token, path) { + ctor <- pecotmr:::.twasMethodCtorFor(token, path) + if (is.null(ctor)) { + return(NA_character_) + } + exports <- getNamespaceExports("pecotmr") + candidates <- exports[str_ends(exports, "Options")] + isCtor <- map_lgl( + mget(candidates, envir = asNamespace("pecotmr")), + identical, + ctor + ) + if (any(isCtor)) candidates[isCtor][[1L]] else "?" +} + test_that("the TWAS Options registry is derived from each implementation", { # It used to be 18 hand-written token -> constructor pairs, which had to # restate a pairing the implementation already declares through its own @@ -2264,69 +2198,40 @@ test_that("the TWAS Options registry is derived from each implementation", { pecotmr:::.twasConfigurableMethods(), names(pecotmr:::.twasMethodCapabilities) ) - # Every configurable method has a constructor on each path it runs on. + # Every configurable method resolves, on each path it runs on, to an + # exported *Options constructor a caller can build its options with. The + # pairs themselves are pinned in the next test. 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)) { - return(NA_character_) - } - hit <- keep( - grep("Options$", getNamespaceExports("pecotmr"), value = TRUE), - function(n) identical(get(n, envir = asNamespace("pecotmr")), f) + ctorNames <- map_chr(toks, optionsCtorName, path = path) + expect_equal( + toks[is.na(ctorNames) | ctorNames == "?"], + character(0), + info = path ) - if (length(hit) > 0L) hit[[1L]] else "?" } - # Spot-check the pairs the derivation must reproduce. - 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", { - nameOf <- function(f) { - if (is.null(f)) { - return(NA_character_) - } - hit <- keep( - grep("Options$", getNamespaceExports("pecotmr"), value = TRUE), - function(n) identical(get(n, envir = asNamespace("pecotmr")), f) - ) - if (length(hit) > 0L) hit[[1L]] else "?" - } # The two paths of one method can reach different PACKAGES, which is why # one constructor per method was never enough. - expect_equal( - nameOf(pecotmr:::.twasMethodCtorFor("lasso", "QtlDataset")), - "GlmnetOptions" - ) - expect_equal( - nameOf(pecotmr:::.twasMethodCtorFor("lasso", "QtlSumStats")), - "LassosumOptions" - ) - expect_equal( - nameOf(pecotmr:::.twasMethodCtorFor("dprGibbs", "QtlSumStats")), - "SdprOptions" - ) - expect_equal( - nameOf(pecotmr:::.twasMethodCtorFor("mrmash", "QtlSumStats")), - "MrmashRssOptions" - ) + expect_equal(optionsCtorName("lasso", "QtlDataset"), "GlmnetOptions") + expect_equal(optionsCtorName("lasso", "QtlSumStats"), "LassosumOptions") + expect_equal(optionsCtorName("mcp", "QtlDataset"), "NcvregOptions") + expect_equal(optionsCtorName("bayesB", "QtlDataset"), "BglrOptions") + expect_equal(optionsCtorName("dprGibbs", "QtlSumStats"), "SdprOptions") + expect_equal(optionsCtorName("mrmash", "QtlSumStats"), "MrmashRssOptions") + # enet and ridge run on summary statistics through the penalized solver. + expect_equal(optionsCtorName("enet", "QtlSumStats"), "PenalizedRssOptions") + expect_equal(optionsCtorName("ridge", "QtlDataset"), "GlmnetOptions") + # prsCs has no individual implementation; its one constructor is the + # summary-statistics one. + expect_equal(optionsCtorName("prsCs", "QtlSumStats"), "PrsCsOptions") # A method that does not run on a path has no constructor there. - expect_null(pecotmr:::.twasMethodCtorFor("enet", "QtlSumStats")) + expect_null(pecotmr:::.twasMethodCtorFor("dprVb", "QtlSumStats")) expect_null(pecotmr:::.twasMethodCtorFor("prsCs", "QtlDataset")) expect_null(pecotmr:::.twasMethodCtorFor("nosuch", "QtlDataset")) }) @@ -2351,6 +2256,8 @@ test_that("name lookups answer NA / NULL when the name resolves to nothing", { ) expect_null(pecotmr:::.twasImplCtorName("noSuchImplAnywhere")) expect_null(pecotmr:::.twasImplCtorName(NULL)) + # A token no weightMethods name spells has no arguments to look up. + expect_null(pecotmr:::.twasMethodArgsFor(list(), "susie")) }) test_that(".twasCanonicalShortName maps a function name back, else passes on", { @@ -2368,13 +2275,190 @@ test_that(".twasFoldFitsFor answers NULL when no spelling is present", { expect_null(f(list(somethingElse = list()), "susie")) }) -test_that(".twasFoldFit leaves args alone when there is no fold fit", { - f <- pecotmr:::.twasFoldFit - args <- list(X = 1) - # No CV payload at all. - expect_identical(f(args, "susie", 1L, NULL), args) - # A method with no fine-mapping token to look up. - expect_identical(f(args, "lasso", 1L, list(susie = list())), args) - # The token is present but carries no folds, so there is nothing to add. - expect_identical(f(args, "susie", 1L, list(susie = list())), args) +# =========================================================================== +# metadata, and the variants each row's fits were made on +# =========================================================================== + +.tw_ids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + +# A TwasWeights of one row per payload in `rows`, named r1, r2, ... +.tw_collection <- function(rows, metadata = list()) { + n <- length(rows) + TwasWeights( + studyName = rep("s1", n), + context = rep("c1", n), + trait = sprintf("g%d", seq_len(n)), + method = rep("lasso", n), + entry = rows, + metadata = metadata + ) +} + +test_that("TwasWeights() keeps the caller's metadata", { + tw <- .tw_collection( + list(TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3))), + metadata = list(run = "r1") + ) + expect_equal(S4Vectors::metadata(tw), list(run = "r1")) +}) + +test_that("a weights row records its fit variants only with a fit payload", { + tw <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)), + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)) + )) + expect_s4_class(tw$fitVariants, "CharacterList") + expect_equal(as.character(tw$fitVariants[[1L]]), .tw_ids) + expect_equal(as.character(tw$fitVariants[[2L]]), character(0)) +}) + +test_that("cvResult() and methodFits() of a narrowed row warn", { + fits <- list(lasso = list(lambda = 0.1)) + cv <- list(r2 = 0.4) + tw <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), fits, cv) + )) + narrowed <- endoapply(tw, utils::head, 2L) + expect_warning( + out <- cvResult(narrowed), + "cvResult\\(\\): the stored fit was made with 3 variants, 1 of" + ) + expect_identical(out, cv) + expect_warning( + outFits <- methodFits(narrowed), + "methodFits\\(\\): .* Refit on the variants kept" + ) + expect_identical(outFits, fits) + expect_no_warning(cvResult(tw)) + expect_no_warning(methodFits(tw)) +}) + +test_that("updateObject() backfills a fitted row's held variants", { + tw <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)), + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3)) + )) + saved <- tw + saved$fitVariants <- NULL + up <- updateObject(saved) + expect_equal(as.character(up$fitVariants[[1L]]), .tw_ids) + expect_equal(as.character(up$fitVariants[[2L]]), character(0)) + # A current collection is left as it is. + expect_identical(updateObject(tw)$fitVariants, tw$fitVariants) + expect_message(updateObject(tw, verbose = TRUE), "TwasWeights") +}) + +test_that("updateObject() backfills held variants and keys LD rows at once", { + tw <- .tw_collection(list( + TwasWeightsRow(.tw_ids, c(0.1, 0.2, 0.3), cvResult = list(r2 = 0.4)) + )) + saved <- tw + saved$fitVariants <- NULL + up <- updateObject(.savedWithLdSketch(saved, NULL)) + expect_true(validObject(up)) + expect_equal(as.character(up$fitVariants[[1L]]), .tw_ids) + expect_identical(ldReference(up), list()) + expect_true(is.na(up$ldReference)) + expect_identical(updateObject(up), up) +}) + +# =========================================================================== +# estimateSparsity +# =========================================================================== + +test_that("estimateSparsity: legacy list input reads attr(.,'fit')$pi", { + # Build a weight result that mimics learnTwasWeights keeping its fits: + # element name carries the `_weights` suffix; attr 'fit' carries an mr.ash + # object whose pi[1] is the spike weight. + fake_w <- structure(c(0.1, 0, 0.3), fit = list(pi = c(0.6, 0.2, 0.2))) + weightResults <- list(mrash_weights = fake_w) + expect_equal(estimateSparsity(weightResults), 1 - 0.6, tolerance = 1e-12) +}) + +test_that("estimateSparsity: TwasWeights collection input reads from the mrash entry", { + entry <- TwasWeightsRow( + variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), + weights = c(0.1, 0, 0.3), + methodFits = list(pi = c(0.7, 0.2, 0.1)), + weightStandardized = FALSE + ) + tw <- TwasWeights( + studyName = "s1", + context = "c1", + trait = "t1", + method = "mrash", + entry = list(entry) + ) + expect_equal(estimateSparsity(tw), 1 - 0.7, tolerance = 1e-12) +}) + +test_that("estimateSparsity: TwasWeights without mrash entry errors", { + entry <- TwasWeightsRow(variantIds = c("chr1:100:A:G"), weights = c(0.1)) + tw <- TwasWeights( + studyName = "s1", + context = "c1", + trait = "t1", + method = "lasso", + entry = list(entry) + ) + expect_error( + estimateSparsity(tw), + "mr.ash entry not found in TwasWeights" + ) +}) + +test_that("estimateSparsity: TwasWeights with mrash entry but no fit$pi errors", { + entry <- TwasWeightsRow( + variantIds = c("chr1:100:A:G"), + weights = c(0.1), + methodFits = list(other = 1) + ) + tw <- TwasWeights( + studyName = "s1", + context = "c1", + trait = "t1", + method = "mrash", + entry = list(entry) + ) + expect_error( + estimateSparsity(tw), + "mr.ash fit object not found" + ) +}) + +test_that("estimateSparsity: legacy list input without mrash_weights errors", { + expect_error( + estimateSparsity(list(lasso = c(0.1, 0.2))), + "'mrash_weights'.*not found" + ) +}) + +test_that("estimateSparsity: legacy list input without fit attr errors", { + expect_error( + estimateSparsity(list(mrash_weights = c(0.1, 0.2))), + "mr.ash fit object not found" + ) +}) + +# =========================================================================== +# .twasMethodMap +# =========================================================================== + +test_that("ser is reachable as a TWAS method", { + # It is fit-derived like susie/mvsusie, so it carries no learner + # arguments and its entry is an empty stub. + expect_true(is_in("ser", names(pecotmr:::.twasMethodMap))) + expect_equal(pecotmr:::.twasMethodMap$ser$impl, "serWeights") + expect_length(pecotmr:::.twasMethodMap$ser$args, 0L) + expect_setequal( + pecotmr:::.twasNormalizeMethods(c("ser", "lasso"))$tokens, + c("ser", "lasso") + ) + # Nothing to configure, same as the other fit-derived methods. + expect_error( + TwasWeightsMethodsParam( + qtlSumStatsMethods = list(ser = list(nope = 1)) + ), + "nothing to configure here" + ) }) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 87955b57..169873e1 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -26,7 +26,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") format = "plink2", snpInfo = data.frame( SNP = sprintf("chr1:%d:A:G", 100L * seq_len(snp_n)), - CHR = rep("1", snp_n), + CHR = rep("chr1", snp_n), BP = seq(100L, by = 100L, length.out = snp_n), A1 = rep("A", snp_n), A2 = rep("G", snp_n), @@ -159,7 +159,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") pip = c(0.9, 0.5, 0.1), stringsAsFactors = FALSE ) - fineMappingRow( + FineMappingRow( variantIds = tl$variant_id, susieFit = fitPayload, topLoci = tl @@ -236,8 +236,7 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) # Provenance, aligned per row (.tp_makeSe: ENSG_A -> chr1:1000-1499, # ENSG_B -> chr1:2000-2499). traitPos = the bare trait position (no - # cis-window); region = that position expanded by cisWindow (1000), start - # clamped at 1. + # cis-window). reg <- genomicRegion(res) tp <- traitPosition(res) expect_s4_class(reg, "GRanges") @@ -249,7 +248,7 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" expect_true(all(GenomicRanges::end(tp)[res$trait == "ENSG_A"] == 1499L)) expect_true(all(GenomicRanges::start(tp)[res$trait == "ENSG_B"] == 2000L)) # region: the REALIZED variant span now, not traitPos +/- cisWindow. The - # nominal window is gone (no correct update rule under subsetRegion); the + # nominal window is gone (no correct update rule under subsetting); the # span is in sync with the variants and still sits inside that window. expect_true(all(GenomicRanges::start(reg)[res$trait == "ENSG_A"] >= 1L)) expect_true(all(GenomicRanges::end(reg)[res$trait == "ENSG_A"] <= 2499L)) @@ -307,7 +306,7 @@ test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tight ) }) -test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-context loop", { +test_that("twasWeightsPipeline(QtlDataset): context narrows the context loop", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") mocks <- c( list(extractBlockGenotypes = .tp_mockExtractor()), @@ -343,7 +342,7 @@ test_that("twasWeightsPipeline(QtlDataset): contexts filter restricts the per-co ) } -test_that("twasWeightsPipeline(QtlDataset): traitId chosen per context", { +test_that("twasWeightsPipeline(QtlDataset): trait chosen per context", { mocks <- c( list(extractBlockGenotypes = .tp_mockExtractor()), .tp_mockIndividualWeights() @@ -458,7 +457,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { gr } -.tp_makeQtlSumStats <- function(n_entries = 1L, qc = TRUE) { +.tp_makeQtlSumStats <- function(n_entries = 1L, qc = TRUE, traitPos = NULL) { studies <- rep("s1", n_entries) contexts <- if (n_entries == 1L) "c1" else paste0("c", seq_len(n_entries)) traits <- rep("t1", n_entries) @@ -470,7 +469,8 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { entry = entries, genome = "hg19", ldReference = .tp_makeHandle(snp_n = 20L), - qcInfo = if (qc) list(step1 = "ok") else list() + qcOptions = if (qc) list(step1 = "ok") else list(), + traitPos = traitPos ) } @@ -525,7 +525,7 @@ test_that("twasWeightsPipeline(QtlSumStats): un-QCd input is rejected", { test_that("twasWeightsPipeline(QtlSumStats): individual-only method rejected", { ss <- .tp_makeQtlSumStats() expect_error( - twasWeightsPipeline(ss, methods = "enet"), + twasWeightsPipeline(ss, methods = "dprVb"), "not available for input class 'QtlSumStats'" ) }) @@ -564,10 +564,7 @@ test_that("twasWeightsPipeline(QtlSumStats): per-method failure surfaces as warn ) }) -test_that("twasWeightsPipeline( - QtlSumStats): multivariate requires >=2 contexts per (study, - trait -)", { +test_that("twasWeightsPipeline(QtlSumStats): mvsusie needs >= 2 contexts", { ss <- .tp_makeQtlSumStats(n_entries = 1L) # 1 context per (study, trait) # Provide a stub fine-mapping result so the gate passes; the multivariate # guard is what we want to exercise here. @@ -579,7 +576,8 @@ test_that("twasWeightsPipeline( ) expect_error( twasWeightsPipeline(ss, methods = "mvsusie", fineMappingResult = fmr), - "multivariate method.*require at least two contexts" + "multivariate method(s) mvsusie require at least two contexts", + fixed = TRUE ) }) @@ -591,45 +589,36 @@ test_that("twasWeightsPipeline( # rule set stays in sync with fineMappingPipeline. # =========================================================================== -test_that("gate: QtlDataset + susie without fineMappingResult errors", { +test_that("gate: each fine-mapping method without fineMappingResult errors", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - expect_error( - twasWeightsPipeline(qd, methods = "susie"), - "are fine-mapping methods and may not be re-fit" - ) -}) - -test_that("gate: QtlSumStats + susieInf without fineMappingResult errors", { - ss <- .tp_makeQtlSumStats() - expect_error( - twasWeightsPipeline(ss, methods = "susieInf"), - "are fine-mapping methods and may not be re-fit" - ) -}) - -test_that("gate: QtlDataset + susieAsh without fineMappingResult errors", { - qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - expect_error( - twasWeightsPipeline(qd, methods = "susieAsh"), - "are fine-mapping methods and may not be re-fit" - ) -}) - -test_that("gate: composite (susie + susieInf) without fineMappingResult errors", { - qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - # Mixed: lasso is allowed, but susie/susieInf must still be gated. - expect_error( - twasWeightsPipeline(qd, methods = c("susie", "susieInf", "lasso")), - "are fine-mapping methods and may not be re-fit" - ) -}) - -test_that("gate: mvsusie without fineMappingResult errors (QtlDataset)", { - qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") - expect_error( - twasWeightsPipeline(qd, methods = "mvsusie"), - "are fine-mapping methods and may not be re-fit" + # Each case: the input it runs on and the methods it asks for. + cases <- list( + "QtlDataset + susie" = list(qd, "susie"), + "QtlSumStats + susieInf" = list(.tp_makeQtlSumStats(), "susieInf"), + "QtlDataset + susieAsh" = list(qd, "susieAsh"), + # Mixed: lasso is allowed, but susie/susieInf must still be gated. + "QtlDataset + susie, susieInf, lasso" = list( + qd, + c("susie", "susieInf", "lasso") + ), + "QtlDataset (two contexts) + mvsusie" = list( + .tp_makeQtlDataset( + contexts = c("brain", "liver"), + traits = "ENSG_A" + ), + "mvsusie" + ) ) + for (label in names(cases)) { + expect_error( + twasWeightsPipeline( + cases[[label]][[1L]], + methods = cases[[label]][[2L]] + ), + "are fine-mapping methods and may not be re-fit", + info = label + ) + } }) test_that("gate: fsusie now has a TWAS-weight extractor (accepted with FMR)", { @@ -837,10 +826,7 @@ test_that("gate: missing matching tuple in fineMappingResult warns and skips", { # matrix; we mock that solver to return a zero matrix of the expected shape. # =========================================================================== -test_that("twasWeightsPipeline( - QtlDataset): mvsusie multivariate path returns one row per (context, - trait -)", { +test_that("twasWeightsPipeline(QtlDataset): mvsusie gives a row per context", { qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") fmr <- .tp_makeStubFineMappingResult( studyName = "study1", @@ -877,12 +863,14 @@ test_that("twasWeightsPipeline( ) )) expect_s4_class(res, "TwasWeights") - # Joint fit on 2 contexts x 1 trait -> 2 rows back, one per (context, trait). + # Joint fit on 2 contexts x 1 trait -> 2 rows back, one per (context, + # trait). expect_equal(nrow(res), 2L) expect_setequal(contexts(res), c("brain", "liver")) expect_setequal(traitNames(res), "ENSG_A") expect_setequal(methodNames(res), "mvsusie") - expect_gte(mvCalls, 1L) + # One joint fit serves both contexts. + expect_equal(mvCalls, 1L) }) test_that("twasWeightsPipeline(QtlDataset): mr.mash multivariate path with 2 traits x 2 contexts", { @@ -1012,7 +1000,7 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash retains its fit parts in the entry = entries, genome = "hg19", ldReference = .tp_makeHandle(snp_n = 20L), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) } @@ -1097,7 +1085,7 @@ test_that("twasWeightsPipeline(QtlSumStats): mr.mash multivariate solver failure variant_ids = sprintf("chr1:%d:A:G", 100L * (1:8)), weights = rep(0.5, 8) ) { - twasWeightsRow( + TwasWeightsRow( variantIds = variant_ids, weights = weights, weightStandardized = FALSE @@ -1233,7 +1221,7 @@ test_that(".twasCacheLookup: non-TwasWeights input returns NULL", { }) test_that(".twasCacheLookup: returns matching entry by 4-tuple", { - e <- twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) + e <- TwasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) tw <- TwasWeights( studyName = "s1", context = "c1", @@ -1260,24 +1248,20 @@ test_that("twasWeightsPipeline(ANY): unsupported input class errors", { }) # =========================================================================== -# twasMultivariateWeightsPipeline +# Both multivariate methods in one run # =========================================================================== -# twasMultivariateWeightsPipeline() was a deprecation stub and was removed in -# 2be68392; its documented replacement is twasWeightsPipeline() with both -# multivariate tokens passed together. That migration path is what is tested -# here -- the two solvers must fit side by side and partition their output by -# (study, context, trait, method) rather than collide. +# twasWeightsPipeline() with both multivariate tokens passed together: the two +# solvers must fit side by side and partition their output by (study, context, +# trait, method) rather than collide. test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { - qd <- .tp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) + # One trait over two contexts is a multivariate group for both methods. + qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") fmr <- .tp_makeStubFineMappingResult( studyName = "study1", contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B"), + traits = "ENSG_A", method = "mvsusie" ) mvCalls <- 0L @@ -1320,16 +1304,10 @@ test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { expect_gte(mrCalls, 1L) expect_setequal(methodNames(res), c("mrmash", "mvsusie")) expect_setequal(contexts(res), c("brain", "liver")) - expect_setequal(traitNames(res), c("ENSG_A", "ENSG_B")) - # 2 contexts x 2 traits x 2 methods, with no method overwriting the other. - expect_equal(nrow(res), 8L) + expect_setequal(traitNames(res), "ENSG_A") + # 2 contexts x 1 trait x 2 methods, with no method overwriting the other. + expect_equal(nrow(res), 4L) }) -# imputeMissingGwasForSketch was removed: it duplicated the inline RAISS -# imputation step at the bottom of .runEntrySummaryStatsQc (sumstatsQc.R), -# had no production callers, and was orphaned post-S4-refactor. The RAISS- -# against-sketch path that does run in production is exercised via the -# summaryStatsQc test file (with raiss() left to run for real on the small -# fixture). context("ensembleWeights") @@ -1463,29 +1441,12 @@ test_that("ensembleWeights: multi-dataset with different methods errors", { # =========================================================================== # Core algorithm correctness +# +# Coefficient validity, the best method's share and the weight combination +# are asserted per solver, the default (quadprog) included, under "Solver +# alternatives" below. # =========================================================================== -test_that("ensembleWeights: coefficients are non-negative and sum to 1", { - cv <- makeCvResult(n = 100, K = 4, seed = 42) - res <- ensembleWeights(cv, Y = cv$.y) - - expect_true(all(res$methodCoef >= 0)) - expect_equal(sum(res$methodCoef), 1, tolerance = 1e-6) -}) - -test_that("ensembleWeights: best method receives the largest coefficient", { - # Method 1 is best (lowest noise), method K is worst - cv <- makeCvResult( - n = 200, - K = 4, - seed = 7, - method_quality = c(0.1, 0.5, 0.8, 1.2) - ) - res <- ensembleWeights(cv, Y = cv$.y) - - expect_equal(names(which.max(res$methodCoef)), "method1") -}) - test_that("ensembleWeights: does not return ensemble_performance (in-sample R^2 omitted)", { cv <- makeCvResult(n = 300, K = 5, seed = 13) res <- ensembleWeights(cv, Y = cv$.y) @@ -1518,41 +1479,31 @@ test_that("ensembleWeights: method names are stripped of _predicted suffix", { # Sample name alignment # =========================================================================== -test_that("ensembleWeights: aligns Y and predictions by sample name", { +test_that("ensembleWeights: aligns a Y vector or matrix by sample name", { cv <- makeCvResult(n = 50, K = 3, seed = 10) - - # Shuffle Y order relative to predictions - shuffled_order <- sample(50) - y_shuffled <- cv$.y[shuffled_order] - names(y_shuffled) <- paste0("sample_", shuffled_order) - - res_aligned <- ensembleWeights(cv, Y = y_shuffled) res_original <- ensembleWeights(cv, Y = cv$.y) - # Results should be identical regardless of Y order - expect_equal( - res_aligned$methodCoef, - res_original$methodCoef, - tolerance = 1e-10 - ) -}) - -test_that("ensembleWeights: aligns Y matrix and predictions by sample name", { - cv <- makeCvResult(n = 50, K = 3, seed = 10) - - # Create Y as a matrix with shuffled row order + # Shuffle Y order relative to predictions shuffled_order <- sample(50) - Y_mat <- matrix(cv$.y[shuffled_order], ncol = 1) - rownames(Y_mat) <- paste0("sample_", shuffled_order) - - res_aligned <- ensembleWeights(cv, Y = Y_mat) - res_original <- ensembleWeights(cv, Y = cv$.y) - - expect_equal( - res_aligned$methodCoef, - res_original$methodCoef, - tolerance = 1e-10 + sampleIds <- paste0("sample_", shuffled_order) + shapes <- list( + vector = setNames(cv$.y[shuffled_order], sampleIds), + matrix = matrix( + cv$.y[shuffled_order], + ncol = 1, + dimnames = list(sampleIds, NULL) + ) ) + for (shape in names(shapes)) { + res_aligned <- ensembleWeights(cv, Y = shapes[[shape]]) + # Results should be identical regardless of Y order + expect_equal( + res_aligned$methodCoef, + res_original$methodCoef, + tolerance = 1e-10, + info = shape + ) + } }) test_that("ensembleWeights: errors when no common sample names", { @@ -1594,30 +1545,9 @@ test_that("ensembleWeights: all zero-variance methods errors", { }) # =========================================================================== -# Weight combination +# Weight combination (sum of zeta_k * w_k: see "Solver alternatives") # =========================================================================== -test_that("ensembleWeights: ensembleTwasWeights is sum of zeta_k * w_k", { - cv <- makeCvResult(n = 100, K = 3, seed = 42) - wt <- makeWeightList(p = 10, method_names = cv$.method_names) - - res <- ensembleWeights(cv, Y = cv$.y, twasWeightList = wt) - - expect_false(is.null(res$ensembleTwasWeights)) - - # Verify the combination is correct - expected <- matrix(0, nrow = 10, ncol = 1) - for (k in seq_along(cv$.method_names)) { - m <- cv$.method_names[k] - expected <- expected + res$methodCoef[m] * wt[[paste0(m, "_weights")]] - } - expect_equal( - as.numeric(res$ensembleTwasWeights), - as.numeric(expected), - tolerance = 1e-10 - ) -}) - test_that("ensembleWeights: NULL twas_weight_list returns NULL ensembleTwasWeights", { cv <- makeCvResult(n = 50, K = 3, seed = 1) res <- ensembleWeights(cv, Y = cv$.y, twasWeightList = NULL) @@ -1697,10 +1627,6 @@ test_that("ensembleWeights: end-to-end with twasWeightsCv output", { expect_null(res$ensemble_performance) }) -# =========================================================================== -# twasWeightsPipeline ensemble integration -# =========================================================================== - # =========================================================================== # Solver alternatives # =========================================================================== @@ -1834,15 +1760,6 @@ test_that("ensembleWeights: solver='glmnet' respects alpha parameter", { }) -context("multivariate_pipeline") - -# multivariateAnalysisPipeline and the legacy regionDataToMvsusieRssInput / -# regionDataToSusieRssInput entry points have been removed in the S4 -# refactor. Joint multi-trait/multi-context analyses now run through -# fineMappingPipeline(qtlDataset, methods = "mvsusie") (individual-level) -# or fineMappingPipeline(..., methods = "mvsusieRSS") (RSS-based). -# Coverage for those pipelines lives alongside their implementations. - context("twasWeights internal helpers") # =========================================================================== @@ -1855,18 +1772,27 @@ test_that(".twasNormalizeMethods: NULL falls through to the 'default' preset", { expect_equal(sort(names(res$methodList)), sort(default_names)) }) -test_that(".twasNormalizeMethods: character preset string forwards to .twasMethodLookup", { - res <- pecotmr:::.twasNormalizeMethods("fastDefault") - fast_names <- names(pecotmr:::.twasMethodLookup("fastDefault")) - expect_equal(sort(names(res$methodList)), sort(fast_names)) -}) - -test_that(".twasNormalizeMethods: character vector of short names forwards to .twasMethodLookup", { - res <- pecotmr:::.twasNormalizeMethods(c("lasso", "enet")) - expect_equal( - sort(names(res$methodList)), - sort(c("lasso_weights", "enet_weights")) +test_that(".twasNormalizeMethods: character methods go to .twasMethodLookup", { + # Each case: a character `methods` (a preset or short names) and the + # method list it expands to. + cases <- list( + preset = list( + "fastDefault", + names(pecotmr:::.twasMethodLookup("fastDefault")) + ), + shortNames = list( + c("lasso", "enet"), + c("lasso_weights", "enet_weights") + ) ) + for (label in names(cases)) { + res <- pecotmr:::.twasNormalizeMethods(cases[[label]][[1L]]) + expect_equal( + sort(names(res$methodList)), + sort(cases[[label]][[2L]]), + info = label + ) + } }) test_that(".twasNormalizeMethods: a methods record passes its kwargs through", { @@ -1937,9 +1863,9 @@ test_that(".twasCheckMethodCapabilities: sumstat-only token + QtlDataset errors" }) test_that(".twasCheckMethodCapabilities: individual-only token + QtlSumStats errors", { - # enet has individualImpl only -- not legal for QtlSumStats. + # dprVb has individualImpl only -- not legal for QtlSumStats. expect_error( - pecotmr:::.twasCheckMethodCapabilities("enet", "QtlSumStats"), + pecotmr:::.twasCheckMethodCapabilities("dprVb", "QtlSumStats"), "is individual-only" ) }) @@ -1994,7 +1920,7 @@ test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, sing # .twasAssertQcd # =========================================================================== -.tw_makeSumStatsBare <- function() { +.tw_makeSumStatsBare <- function(qcOptions = list()) { gr <- GenomicRanges::GRanges( "chr1", IRanges::IRanges(start = c(100L, 200L), width = 1L) @@ -2019,11 +1945,12 @@ test_that(".twasCheckMultivariateY: mvsusie/mrmash error with single trait, sing studyName = "g1", entry = list(gr), genome = "hg19", - ldReference = gh + ldReference = gh, + qcOptions = qcOptions ) } -test_that(".twasAssertQcd: errors when qcInfo is empty", { +test_that(".twasAssertQcd: errors when qcOptions is empty", { ss <- .tw_makeSumStatsBare() expect_error( pecotmr:::.twasAssertQcd(ss), @@ -2031,225 +1958,15 @@ test_that(".twasAssertQcd: errors when qcInfo is empty", { ) }) -test_that(".twasAssertQcd: passes when qcInfo is populated", { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = c(100L, 200L), width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = c("rs1", "rs2"), - A1 = c("A", "A"), - A2 = c("G", "G"), - Z = c(1, 2), - N = c(100L, 100L) - ) - gh <- new( - "GenotypeHandle", - path = "/tmp/x", - format = "plink2", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) - ss <- GwasSumStats( - studyName = "g1", - entry = list(gr), - genome = "hg19", - ldReference = gh, - qcInfo = list(step1 = "ok") - ) +test_that(".twasAssertQcd: passes when qcOptions is populated", { + ss <- .tw_makeSumStatsBare(qcOptions = list(step1 = "ok")) expect_silent(pecotmr:::.twasAssertQcd(ss)) }) -# =========================================================================== -# as.data.frame (public method on GwasSumStats / QtlSumStats; replaces -# the now-deleted `.twasSumstatsEntryToDf` shim) -# =========================================================================== - -.gsd_makeHandle <- function(snp_n = 2L) { - new( - "GenotypeHandle", - path = "/tmp/sketch", - format = "plink2", - snpInfo = data.frame( - SNP = paste0("rs", 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 = 10L, - sampleIds = paste0("s", seq_len(10L)), - pgenPtr = NULL - ) -} - -.gsd_makeGwasSumStats <- function(mcolsDf, snp_n = nrow(mcolsDf)) { - 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(mcolsDf) - GwasSumStats( - studyName = "G1", - entry = list(gr), - genome = "hg19", - ldReference = .gsd_makeHandle(snp_n), - qcInfo = list(prebuilt = "synthetic") - ) -} - -test_that("as.data.frame: returns the canonical column layout", { - ss <- .gsd_makeGwasSumStats(data.frame( - SNP = c("rs1", "rs2"), - A1 = c("A", "A"), - A2 = c("G", "G"), - Z = c(1.0, -2.5), - N = c(1000L, 1500L), - MAF = c(0.1, 0.3) - )) - df <- as.data.frame(ss) - expect_s3_class(df, "data.frame") - expect_equal(df$variant_id, c("rs1", "rs2")) - expect_equal(df$chrom, c("chr1", "chr1")) - expect_equal(df$pos, c(100L, 200L)) - expect_equal(df$z, c(1.0, -2.5)) - expect_equal(df$N, c(1000, 1500)) - expect_equal(df$maf, c(0.1, 0.3)) -}) - -test_that("as.data.frame: derives z from beta/se when derive='zFromBetaSe'", { - ss <- .gsd_makeGwasSumStats( - data.frame( - SNP = "rs1", - A1 = "A", - A2 = "G", - BETA = 0.5, - SE = 0.1, - N = 1000L - ), - snp_n = 1L - ) - df <- as.data.frame(ss, derive = "zFromBetaSe") - expect_equal(df$beta, 0.5) - expect_equal(df$se, 0.1) - expect_equal(df$z, 0.5 / 0.1) -}) - -test_that("as.data.frame: omits optional columns when absent", { - ss <- .gsd_makeGwasSumStats( - data.frame( - SNP = "rs1", - A1 = "A", - A2 = "G" - ), - snp_n = 1L - ) - df <- as.data.frame(ss) - expect_false("z" %in% names(df)) - expect_false("beta" %in% names(df)) - expect_false("se" %in% names(df)) - expect_false("N" %in% names(df)) - expect_false("maf" %in% names(df)) -}) - -test_that("as.data.frame: require=c('Z','N') errors when columns missing", { - ss <- .gsd_makeGwasSumStats( - data.frame( - SNP = "rs1", - A1 = "A", - A2 = "G", - Z = 1.5 - ), - snp_n = 1L - ) - expect_error(as.data.frame(ss, require = c("Z", "N")), "no N mcol") -}) - # =========================================================================== # estimateSparsity # =========================================================================== -test_that("estimateSparsity: legacy list input reads attr(.,'fit')$pi", { - # Build a weight result that mimics learnTwasWeights keeping its fits: - # element name carries the `_weights` suffix; attr 'fit' carries an mr.ash - # object whose pi[1] is the spike weight. - fake_w <- structure(c(0.1, 0, 0.3), fit = list(pi = c(0.6, 0.2, 0.2))) - weightResults <- list(mrash_weights = fake_w) - expect_equal(estimateSparsity(weightResults), 1 - 0.6, tolerance = 1e-12) -}) - -test_that("estimateSparsity: TwasWeights collection input reads from the mrash entry", { - entry <- twasWeightsRow( - variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), - weights = c(0.1, 0, 0.3), - methodFits = list(pi = c(0.7, 0.2, 0.1)), - weightStandardized = FALSE - ) - tw <- TwasWeights( - studyName = "s1", - context = "c1", - trait = "t1", - method = "mrash", - entry = list(entry) - ) - expect_equal(estimateSparsity(tw), 1 - 0.7, tolerance = 1e-12) -}) - -test_that("estimateSparsity: TwasWeights without mrash entry errors", { - entry <- twasWeightsRow(variantIds = c("chr1:100:A:G"), weights = c(0.1)) - tw <- TwasWeights( - studyName = "s1", - context = "c1", - trait = "t1", - method = "lasso", - entry = list(entry) - ) - expect_error( - estimateSparsity(tw), - "mr.ash entry not found in TwasWeights" - ) -}) - -test_that("estimateSparsity: TwasWeights with mrash entry but no fit$pi errors", { - entry <- twasWeightsRow( - variantIds = c("chr1:100:A:G"), - weights = c(0.1), - methodFits = list(other = 1) - ) - tw <- TwasWeights( - studyName = "s1", - context = "c1", - trait = "t1", - method = "mrash", - entry = list(entry) - ) - expect_error( - estimateSparsity(tw), - "mr.ash fit object not found" - ) -}) - -test_that("estimateSparsity: legacy list input without mrash_weights errors", { - expect_error( - estimateSparsity(list(lasso = c(0.1, 0.2))), - "'mrash_weights'.*not found" - ) -}) - -test_that("estimateSparsity: legacy list input without fit attr errors", { - expect_error( - estimateSparsity(list(mrash_weights = c(0.1, 0.2))), - "mr.ash fit object not found" - ) -}) - - context("twasWeights internal helpers (extra)") # =========================================================================== @@ -2257,7 +1974,7 @@ context("twasWeights internal helpers (extra)") # =========================================================================== .tw_makeFmEntry <- function(method_tag = "susie", n = 3) { - fineMappingRow( + FineMappingRow( variantIds = sprintf("chr1:%d:A:G", 100L * seq_len(n)), susieFit = list(payload = method_tag), topLoci = data.frame( @@ -2350,14 +2067,6 @@ test_that(".twasFineMappingFits: ignores non-susie methods (e.g. lasso)", { expect_equal(names(out), "susie") }) -# =========================================================================== -# .twasWeightsPipelineMatrix: susieFit pre-fit pass-through -# =========================================================================== - -# =========================================================================== -# .twasWeightsPipelineMatrix: empirical pi path via mr.ash (mocked) -# =========================================================================== - # =========================================================================== # Multi-region / jointRegions (P3) # =========================================================================== @@ -2383,7 +2092,7 @@ test_that(".twasRegionLabel / .twasFitsForRegion select per-region fits", { test_that(".twasMergeRegionEntries stacks weights and builds a flat per-region CV df", { mk <- function(vids, w, rsq) { - twasWeightsRow( + TwasWeightsRow( variantIds = vids, weights = w, cvResult = list( @@ -2414,7 +2123,7 @@ test_that(".twasMergeRegionEntries stacks weights and builds a flat per-region C }) test_that(".twasMergeRegionEntries returns a single entry unchanged", { - e <- twasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) + e <- TwasWeightsRow(variantIds = "chr1:100:A:G", weights = 0.5) expect_identical( pecotmr:::.twasMergeRegionEntries(list(e), "chr1:1-100"), e @@ -2423,7 +2132,7 @@ test_that(".twasMergeRegionEntries returns a single entry unchanged", { test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { mk <- function(vids, w) { - twasWeightsRow(variantIds = vids, weights = w) + TwasWeightsRow(variantIds = vids, weights = w) } m1 <- matrix( c(0.1, 0.2, 0.3, 0.4), @@ -2472,6 +2181,20 @@ test_that(".twasNormalizeCharMethods: fine-mapping-only tokens skip lookup", { expect_equal(res$methodList[["fsusie_weights"]], list()) }) +test_that("twasWeightsPipeline(QtlDataset): region is a GRanges", { + # Given in R, a window is a GRanges; a string or a table is refused rather + # than read, so its base is never in doubt. + expect_error( + twasWeightsPipeline( + .tp_makeQtlDataset(traits = "ENSG_A"), + methods = list(lasso = list()), + region = "chr1:1-2000" + ), + "`region` must be a GRanges (got character)", + fixed = TRUE + ) +}) + test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { qd <- .tp_makeQtlDataset(traits = "ENSG_A") expect_error( @@ -2485,7 +2208,7 @@ test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { ) }) -test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per-region weights", { +test_that("twasWeightsPipeline: per-region and joint fits span both regions", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") exec( local_mocked_bindings, @@ -2499,9 +2222,63 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- "chr1", IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) ) - res <- suppressMessages(twasWeightsPipeline( + # jointRegions = FALSE concatenates per-region weights; TRUE fits one + # concatenated block. + for (jointRegions in c(FALSE, TRUE)) { + info <- str_c("jointRegions = ", jointRegions) + res <- suppressMessages(twasWeightsPipeline( + qd, + methods = list(lasso = list()), + traitId = "ENSG_A", + region = regions, + jointRegions = jointRegions, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + )) + expect_true(is(res, "TwasWeights"), info = info) + # 1 ctx x 1 trait x 1 method -> a single row. + expect_equal(nrow(res), 1L, info = info) + w <- weights( + res, + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "lasso" + ) + # union of both sub-ranges (v1..v10 + v11..v20). + expect_equal(length(w), 20L, info = info) + } +}) + +test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatenates per-region weights", { + # One trait over two contexts is the multivariate group mr.mash fits. + qd <- .tp_makeQtlDataset(contexts = c("brain", "liver"), traits = "ENSG_A") + exec( + local_mocked_bindings, + !!!c( + list( + extractBlockGenotypes = .tp_mockExtractor(), + mrmashWeights = function(X, Y, ...) { + matrix( + 0, + nrow = ncol(X), + ncol = ncol(Y), + dimnames = list(colnames(X), colnames(Y)) + ) + } + ), + list(.package = "pecotmr") + ) + ) + regions <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) + ) + res <- suppressMessages(suppressWarnings(twasWeightsPipeline( qd, - methods = list(lasso = list()), + methods = "mrmash", traitId = "ENSG_A", region = regions, jointRegions = FALSE, @@ -2509,97 +2286,10 @@ test_that("twasWeightsPipeline(QtlDataset): jointRegions=FALSE concatenates per- verbose = 0, crossValidationParam = CrossValidationParam(folds = 0), ensembleParam = EnsembleParam() - )) - expect_s4_class(res, "TwasWeights") - # 1 ctx x 1 trait x 1 method -> a single merged row. - expect_equal(nrow(res), 1L) - w <- weights( - res, - studyName = "study1", - context = "brain", - trait = "ENSG_A", - method = "lasso" - ) - # union of both sub-ranges (v1..v10 + v11..v20). - expect_equal(length(w), 20L) -}) - -test_that("twasWeightsPipeline(QtlDataset): jointRegions=TRUE fits one concatenated block", { - qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) - ) - regions <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) - ) - res <- suppressMessages(twasWeightsPipeline( - qd, - methods = list(lasso = list()), - traitId = "ENSG_A", - region = regions, - jointRegions = TRUE, - estimatePi = FALSE, - verbose = 0, - crossValidationParam = CrossValidationParam(folds = 0), - ensembleParam = EnsembleParam() - )) - expect_equal(nrow(res), 1L) - w <- weights( - res, - studyName = "study1", - context = "brain", - trait = "ENSG_A", - method = "lasso" - ) - expect_equal(length(w), 20L) -}) - -test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatenates per-region weights", { - qd <- .tp_makeQtlDataset( - contexts = c("brain", "liver"), - traits = c("ENSG_A", "ENSG_B") - ) - exec( - local_mocked_bindings, - !!!c( - list( - extractBlockGenotypes = .tp_mockExtractor(), - mrmashWeights = function(X, Y, ...) { - matrix( - 0, - nrow = ncol(X), - ncol = ncol(Y), - dimnames = list(colnames(X), colnames(Y)) - ) - } - ), - list(.package = "pecotmr") - ) - ) - regions <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(c(50L, 1050L), c(1050L, 2050L)) - ) - res <- suppressMessages(suppressWarnings(twasWeightsPipeline( - qd, - methods = "mrmash", - traitId = c("ENSG_A", "ENSG_B"), - region = regions, - jointRegions = FALSE, - estimatePi = FALSE, - verbose = 0, - crossValidationParam = CrossValidationParam(folds = 0), - ensembleParam = EnsembleParam() ))) expect_s4_class(res, "TwasWeights") - # 2 contexts x 2 traits = 4 rows, each with weights concatenated over regions. - expect_equal(nrow(res), 4L) + # 2 contexts x 1 trait = 2 rows, each concatenated over the regions. + expect_equal(nrow(res), 2L) w <- weights( res, studyName = "study1", @@ -2612,9 +2302,9 @@ test_that("twasWeightsPipeline(QtlDataset): mr.mash jointRegions=FALSE concatena # =========================================================================== # fineMapping -> TWAS cross-validation handoff: .twasCvResultFor merges the -# per-method cvResult stashed on a fine-mapping tuple's entries, and -# .twasWeightsPipelineMatrix adopts that partition + predictions instead of -# refitting the handed-over methods. +# per-method cvResult stashed on a fine-mapping tuple's entries, so the TWAS +# run adopts that partition + predictions instead of refitting the +# handed-over methods. # =========================================================================== test_that(".twasCvResultFor merges per-method cvResult across a tuple's entries", { @@ -2637,13 +2327,13 @@ test_that(".twasCvResultFor merges per-method cvResult across a tuple's entries" ) ) } - eSusie <- fineMappingRow( + eSusie <- FineMappingRow( "chr1:100:A:G", list(), tl, cvResult = mkCv("susie") ) - eInf <- fineMappingRow( + eInf <- FineMappingRow( "chr1:100:A:G", list(), tl, @@ -2674,7 +2364,7 @@ test_that(".twasCvResultFor returns NULL when no entry carries CV", { pip = 0.5, stringsAsFactors = FALSE ) - e <- fineMappingRow("chr1:100:A:G", list(), tl) + e <- FineMappingRow("chr1:100:A:G", list(), tl) fmr <- QtlFineMappingResult( studyName = "S", context = "C", @@ -2745,7 +2435,7 @@ test_that(".unpackMashPrior routes a MashPrior into the internal CV arguments", context = context, trait = trait, method = method, - entry = list(twasWeightsRow(variantIds = vid, weights = w)) + entry = list(TwasWeightsRow(variantIds = vid, weights = w)) ) } @@ -2865,7 +2555,7 @@ test_that(".twasCvResultFor: a multi-region (per-region list) cvResult is unwrap performance = list(susie_performance = matrix(0, 1, 6)) ) ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.9), @@ -3264,8 +2954,19 @@ test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type ) }) -test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching rows", { - ss <- .tp_makeQtlSumStats() +test_that("twasWeightsPipeline(QtlSumStats): trait selects matching rows", { + # Two traits in one context, so selecting the second must drop the + # first. A trait that matches no row is pinned by "empty contexts/trait + # filter errors" above. + ss <- QtlSumStats( + studyName = c("s1", "s1"), + context = c("c1", "c1"), + trait = c("t1", "t2"), + entry = list(.tp_makeSumstatsEntry(), .tp_makeSumstatsEntry()), + genome = "hg19", + ldReference = .tp_makeHandle(snp_n = 20L), + qcOptions = list(step1 = "ok") + ) exec( local_mocked_bindings, !!!c( @@ -3275,13 +2976,11 @@ test_that("twasWeightsPipeline(QtlSumStats): traitId filter selects matching row ) ) res <- suppressMessages(suppressWarnings( - twasWeightsPipeline(ss, methods = "lasso", traitId = "t1", verbose = 0) + twasWeightsPipeline(ss, methods = "lasso", traitId = "t2", verbose = 0) )) - expect_setequal(traitNames(res), "t1") - expect_error( - twasWeightsPipeline(ss, methods = "lasso", traitId = "absent"), - "no entries matched" - ) + expect_equal(as.character(res$trait), "t2") + expect_equal(as.character(res$context), "c1") + expect_equal(as.character(res$method), "lasso") }) test_that("twasWeightsPipeline(QtlSumStats): multivariate mr.mash returns a column per context", { @@ -3336,7 +3035,9 @@ test_that("twasWeightsPipeline(QtlSumStats): fine-mapping method absent from fin .tp_makeMultiStudy <- function() { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") # study1 - ss <- .tp_makeQtlSumStats() # s1 + # s1, with a trait position: the collection lays its `cisWindow` there + # too, and 1000 bp around it keeps every variant. + ss <- .tp_makeQtlSumStats(traitPos = GenomicRanges::GRanges("chr1:400")) MultiStudyQtlDataset(qtlDatasets = list(study1 = qd), sumStats = ss) } @@ -3436,7 +3137,10 @@ test_that("MultiStudyQtlDataset takes every component argument", { expect_equal(setdiff(comp, ms), character(0)) expect_equal(setdiff(ms, comp), character(0)) expect_equal( - setdiff(ms, c(.cfgFieldNames(".twasMsCfg"), "jointSpecification")), + setdiff( + ms, + c(.cfgFieldNames(".twasMsCfg"), "jointSpecification") + ), character(0) ) }) @@ -3453,8 +3157,7 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): a misspelled option errors ) }) -test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components and rbinds", { - mt <- .tp_makeMultiStudy() +test_that("twasWeightsPipeline(MSQD) rbinds both, lays cisWindow on sumstats", { exec( local_mocked_bindings, !!!c( @@ -3465,16 +3168,35 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): recurses into components a ) ) res <- suppressMessages(suppressWarnings(twasWeightsPipeline( - mt, + .tp_makeMultiStudy(), methods = "lasso", - cisWindow = 1000L, + cisWindow = 100L, estimatePi = FALSE, verbose = 0, crossValidationParam = CrossValidationParam(folds = 0), ensembleParam = EnsembleParam() ))) + # It recurses into both components and rbinds what each phase fitted. expect_s4_class(res, "TwasWeights") - expect_setequal(as.character(res$study), c("study1", "s1")) # both phases + expect_setequal(as.character(res$study), c("study1", "s1")) + fromSumStats <- which(res$study == "s1") + expect_identical( + as.character(genomicRegion(res)[fromSumStats]), + "chr1:300-500" + ) + # A summary-statistics study without a trait position is an error, as it + # is on its own. + bare <- MultiStudyQtlDataset( + qtlDatasets = list( + study1 = .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + ), + sumStats = .tp_makeQtlSumStats() + ) + expect_error( + twasWeightsPipeline(bare, methods = "lasso", cisWindow = 100L), + "twasWeightsPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) }) test_that("twasWeightsPipeline(MultiStudyQtlDataset): region + cisWindow is rejected", { @@ -3490,6 +3212,40 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): region + cisWindow is reje ) }) +test_that("twasWeightsPipeline(MultiStudy): trait selection skips a study", { + # A trait vector applies to every component: one carrying none of the + # traits sits out, and the run is refused only when none carries any. + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + ) + mt <- .tp_makeMultiStudy() + fit <- function(traitId) { + suppressMessages(twasWeightsPipeline( + mt, + methods = "lasso", + traitId = traitId, + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + )) + } + expect_setequal(as.character(fit("t1")$study), "s1") + expect_setequal(as.character(fit("ENSG_A")$study), "study1") + expect_error( + fit("absent"), + "twasWeightsPipeline(MultiStudyQtlDataset): no traits selected.", + fixed = TRUE + ) +}) + test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash returns the joint result", { mt <- .tp_makeMultiStudy() jointRes <- .tp_tw( @@ -3502,15 +3258,19 @@ test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec-only mr.mash ret .twasDispatchJointSpecsMultiStudy = function(...) jointRes, .package = "pecotmr" ) - res <- suppressMessages(suppressWarnings(twasWeightsPipeline( - mt, - methods = "mrmash", - jointSpecification = "context", - cisWindow = 1000L, - verbose = 0 - ))) - expect_s4_class(res, "TwasWeights") - expect_setequal(as.character(res$method), "mrmash") + # `methods` naming mr.mash alone, in either accepted shape. + for (methods in list("mrmash", list(mrmash = list()))) { + info <- if (is.list(methods)) "list form" else "character form" + res <- suppressMessages(suppressWarnings(twasWeightsPipeline( + mt, + methods = methods, + jointSpecification = "context", + cisWindow = 1000L, + verbose = 0 + ))) + expect_true(is(res, "TwasWeights"), info = info) + expect_equal(unique(as.character(res$method)), "mrmash", info = info) + } }) test_that("twasWeightsPipeline(MultiStudyQtlDataset): jointSpec mr.mash + univariate lasso are combined", { @@ -3567,7 +3327,7 @@ test_that(".twasCvResultFor: an entry whose nested CV carries no partition is sk nested <- list( region1 = list(prediction = list(susie_predicted = matrix(0, 1, 1))) ) - entry <- fineMappingRow( + entry <- FineMappingRow( variantIds = "chr1:100:A:G", susieFit = list(), topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.9), @@ -3580,7 +3340,7 @@ test_that(".twasCvResultFor: an entry whose nested CV carries no partition is sk method = "susie", entry = list(entry) ) - expect_null(pecotmr:::.twasCvResultFor(fmr, "S", "c1", "t1")) # 616 -> next + expect_null(pecotmr:::.twasCvResultFor(fmr, "S", "c1", "t1")) }) test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash-only with no fits errors", { @@ -3596,7 +3356,7 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash-only with no fits jointSpecification = "context" )), "no joint fits produced" - ) # 1059 + ) }) test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lasso combine", { @@ -3624,15 +3384,13 @@ test_that("twasWeightsPipeline(QtlSumStats): jointSpec mr.mash + univariate lass jointSpecification = "context", verbose = 0 ))) - expect_true("mrmash" %in% as.character(res$method)) # 1062-1063 - expect_true("lasso" %in% as.character(res$method)) # 1300-1301 rbind + expect_true("mrmash" %in% as.character(res$method)) # from the joint result + expect_true("lasso" %in% as.character(res$method)) # from the per-tuple loop }) -test_that("twasWeightsPipeline( - QtlSumStats): a single-context (study, - trait -) group is skipped for mr.mash", { - # t1 has 2 contexts (processed); t2 has 1 context (skipped at the < 2 guard). +test_that("twasWeightsPipeline(QtlSumStats): mr.mash skips 1-context traits", { + # t1 has 2 contexts (processed); t2 has 1 context (skipped at the < 2 + # guard). entries <- map(1:3, function(.) .tp_makeSumstatsEntry()) ss <- QtlSumStats( studyName = rep("s1", 3), @@ -3641,7 +3399,7 @@ test_that("twasWeightsPipeline( entry = entries, genome = "hg19", ldReference = .tp_makeHandle(snp_n = 20L), - qcInfo = list(step1 = "ok") + qcOptions = list(step1 = "ok") ) local_mocked_bindings( extractBlockGenotypes = .tp_mockExtractor(), @@ -3655,14 +3413,14 @@ test_that("twasWeightsPipeline( res <- suppressMessages(suppressWarnings( twasWeightsPipeline(ss, methods = "mrmash", verbose = 0) )) - expect_setequal(traitNames(res), "t1") # only t1 (1189) + expect_setequal(traitNames(res), "t1") # only t1 }) test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multivariate group errors", { ss <- .tp_makeQtlSumStats(n_entries = 2L) # (s1, t1) x 2 ctx calls <- 0L local_mocked_bindings( - as.data.frame = function(x, studyName, context, trait, require, ...) { + .sumStatsDf = function(x, studyName, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") @@ -3685,29 +3443,7 @@ test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multiva verbose = 0 )), "identical SNP order" - ) # 1212 -}) - -test_that("twasWeightsPipeline(MultiStudyQtlDataset): list-form methods, joint mr.mash only", { - mt <- .tp_makeMultiStudy() - jointRes <- .tp_tw( - studyName = "s1", - context = "c1", - trait = "t1", - method = "mrmash" - ) - local_mocked_bindings( - .twasDispatchJointSpecsMultiStudy = function(...) jointRes, - .package = "pecotmr" ) - res <- suppressMessages(suppressWarnings(twasWeightsPipeline( - mt, - methods = list(mrmash = list()), - jointSpecification = "context", - cisWindow = 1000L, - verbose = 0 - ))) - expect_setequal(as.character(res$method), "mrmash") # 1360-1377 }) test_that("ensembleWeights: partial sample overlap emits a message", { @@ -3720,7 +3456,7 @@ test_that("ensembleWeights: partial sample overlap emits a message", { expect_message( ensembleWeights(cvResults = list(prediction = pb), Y = y), "common samples" - ) # 1824 + ) }) test_that("ensembleWeights: contextIndex beyond Y matrix columns errors (named path)", { @@ -3737,7 +3473,7 @@ test_that("ensembleWeights: contextIndex beyond Y matrix columns errors (named p contextIndex = 2 ), "exceeds number of columns" - ) # 1830 + ) }) test_that("ensembleWeights: vector (non-matrix) method weights are coerced to a column", { @@ -3768,7 +3504,7 @@ test_that("ensembleWeights: vector (non-matrix) method weights are coerced to a Y = y, twasWeightList = wl ) - expect_length(res$ensembleTwasWeights, 3L) # 1937 / 1947 + expect_length(res$ensembleTwasWeights, 3L) }) test_that(".solveEnsembleNnls: solver failure and all-zero fall back to equal weights", { @@ -3944,31 +3680,55 @@ test_that(".ensembleAccumulateWeights skips a dim-mismatched member", { )))) } -test_that("twasWeightsPipeline(QtlSumStats) filters nothing by default", { - ss <- .twrssf_qcd() - expect_equal(.twrssf_n(ss), sum(lengths(ss))) -}) +# QC'd once: summaryStatsQc() is the costliest step here, and every test +# below only reads its result. +.twrssfQcd <- .twrssf_qcd() -test_that("twasWeightsPipeline(QtlSumStats) drops panel-rare variants", { - ss <- .twrssf_qcd() +test_that("twasWeightsPipeline RSS: no cutoff keeps all, cutoffs match panel", { + ss <- .twrssfQcd full <- .twrssf_n(ss) - loose <- .twrssf_n(ss, mafCutoff = 0.05) - tight <- .twrssf_n(ss, mafCutoff = 0.2) - expect_lt(loose, full) - expect_lt(tight, loose) + # Nothing is filtered by default. + expect_equal(full, sum(lengths(ss))) + ids <- .sumStatsDf( + ss, + studyName = ss$study[[1L]], + context = ss$context[[1L]], + trait = ss$trait[[1L]], + require = c("Z", "N"), + derive = "zFromBetaSe" + )$variant_id + cuts <- c(0.05, 0.2) + kept <- map_int(cuts, function(cut) .twrssf_n(ss, mafCutoff = cut)) + # Each MAF cutoff drops panel-rare variants, the stricter one more ... + expect_lt(kept[[1L]], full) + expect_lt(kept[[2L]], kept[[1L]]) + # ... and exactly the variants the shared filter names: no more (something + # else is filtering) and no fewer (the cutoff silently did nothing). + for (i in seq_along(cuts)) { + expect_equal( + kept[[i]], + length(.panelVariantFilter( + ldReference(ss)[[1L]], + ids, + PanelFilterParam(mafCutoff = cuts[[i]]) + )), + label = str_c("mafCutoff ", cuts[[i]]) + ) + } }) 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() + # never supplies, so every entry failed with a warning. A short chain is + # enough to show each method produces its row. + ss <- .twrssfQcd res <- suppressMessages(twasWeightsPipeline( ss, methods = list( - prsCs = PrsCsOptions(nIter = 40, nBurnin = 10, thin = 1, seed = 1), + prsCs = PrsCsOptions(nIter = 20, nBurnin = 5, thin = 1, seed = 1), dprGibbs = SdprOptions( - iter = 40, - burn = 10, + iter = 20, + burn = 5, thin = 1, verbose = FALSE ) @@ -3978,34 +3738,9 @@ test_that("twasWeightsPipeline(QtlSumStats) fits PRS-CS and SDPR", { 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). - ss <- .twrssf_qcd() - ids <- as.data.frame( - ss, - studyName = ss$study[[1L]], - context = ss$context[[1L]], - trait = ss$trait[[1L]], - require = c("Z", "N"), - derive = "zFromBetaSe" - )$variant_id - for (cut in c(0.05, 0.2)) { - expect_equal( - .twrssf_n(ss, mafCutoff = cut), - length(.panelVariantFilter( - ldReference(ss), - ids, - PanelFilterParam(mafCutoff = cut) - )), - label = str_c("mafCutoff ", cut) - ) - } -}) - test_that("twasWeightsPipeline RSS treats MAC as a MAF equivalent", { - ss <- .twrssf_qcd() - nSamp <- ncol(ldReference(ss)) + ss <- .twrssfQcd + nSamp <- ncol(ldReference(ss)[[1L]]) expect_equal( .twrssf_n(ss, macCutoff = 0.1 * 2 * nSamp), .twrssf_n(ss, mafCutoff = 0.1) @@ -4013,14 +3748,14 @@ test_that("twasWeightsPipeline RSS treats MAC as a MAF equivalent", { }) test_that("twasWeightsPipeline RSS honours a missingness cutoff", { - ss <- .twrssf_qcd() + ss <- .twrssfQcd expect_lt(.twrssf_n(ss, imissCutoff = 0), sum(lengths(ss))) expect_equal(.twrssf_n(ss, imissCutoff = 1), sum(lengths(ss))) }) test_that(".twasQssUnivariateFitCtx keeps z, ids and LD reference aligned", { - ss <- .twrssf_qcd() - sketch <- ldReference(ss) + ss <- .twrssfQcd + sketch <- ldReference(ss)[[1L]] args <- list(ss, ss$study[[1L]], ss$context[[1L]], ss$trait[[1L]], sketch) plain <- exec(pecotmr:::.twasQssUnivariateFitCtx, !!!args) cut <- suppressMessages(exec( @@ -4222,7 +3957,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, ldReference = NULL), + pecotmr:::.twasQssAssemble(list(), jr), jr ) }) @@ -4281,7 +4016,7 @@ test_that(".fmrAnyCvResult reports whether any row carries cross-validation", { pip = 0.5, stringsAsFactors = FALSE ) - bare <- fineMappingRow("chr1:100:A:G", list(), tl) + bare <- FineMappingRow("chr1:100:A:G", list(), tl) noCv <- QtlFineMappingResult( studyName = "S", context = "C", @@ -4295,7 +4030,7 @@ test_that(".fmrAnyCvResult reports whether any row carries cross-validation", { context = "C", trait = "T", method = "susie", - entry = list(fineMappingRow( + entry = list(FineMappingRow( "chr1:100:A:G", list(), tl, @@ -4376,29 +4111,6 @@ test_that("an entry must come from that method's constructor for that path", { ) }) -test_that("only an engine that takes `...` goes unchecked", { - # An engine is unchecked for exactly one reason: its own signature ends - # in `...`, so every name is legal and there is nothing to reject. - # cv.glmnet, cv.ncvreg and RcppDPR::fit_model do; the rest enumerate. - skip_if_not_installed("glmnet") - skip_if_not_installed("ncvreg") - expect_output(show(GlmnetOptions()), "NOT checked") - expect_output(show(NcvregOptions()), "NOT checked") - # L0Learn enumerates, and so do all four pecotmr RSS solvers -- each has - # its own constructor rather than riding on the individual-level one. - skip_if_not_installed("L0Learn") - expect_output(show(L0learnOptions()), "checked") - expect_failure(expect_output(show(L0learnOptions()), "NOT checked")) - for (ctor in list( - PenalizedRssOptions, - LassosumOptions, - SdprOptions, - PrsCsOptions - )) { - expect_failure(expect_output(show(ctor()), "NOT checked")) - } -}) - test_that("each path takes that path's own constructor", { # lasso fits with glmnet on individual data and with pecotmr's lassosum # solver on summary statistics. The aggregator accepted either for @@ -4427,10 +4139,10 @@ test_that("each path takes that path's own constructor", { ), "options are for QtlSumStats" ) - # enet has no summary-statistics path at all. + # dprVb has no summary-statistics path at all. expect_error( - TwasWeightsMethodsParam(qtlSumStatsMethods = list(enet = list())), - "enet is not a method this pipeline runs on QtlSumStats" + TwasWeightsMethodsParam(qtlSumStatsMethods = list(dprVb = list())), + "dprVb is not a method this pipeline runs on QtlSumStats" ) }) @@ -4579,21 +4291,18 @@ test_that("twasWeightsPipeline(QtlDataset): usePCA adds top-PC rows", { list(.package = "pecotmr") ) ) - run <- function(usePCA) { - suppressMessages(suppressWarnings(twasWeightsPipeline( - qd, - methods = "lasso", - cisWindow = 1000L, - verbose = 0, - usePCA = usePCA, - nPCs = 2L, - crossValidationParam = CrossValidationParam(folds = 0), - ensembleParam = EnsembleParam() - ))) - } - plain <- run(FALSE) - withPc <- run(TRUE) - expect_false(any(str_detect(as.character(traitNames(plain)), "^topPC"))) + withPc <- suppressMessages(suppressWarnings(twasWeightsPipeline( + qd, + methods = "lasso", + cisWindow = 1000L, + verbose = 0, + usePCA = TRUE, + nPCs = 2L, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + ))) + # Without usePCA there are no PC rows: the end-to-end test at the top of + # this file pins a default run's traitNames to the two genes. pcs <- unique(as.character(traitNames(withPc))) expect_true(any(str_detect(pcs, "^topPC"))) # the per-trait rows are still there -- PC rows are additional @@ -4752,41 +4461,17 @@ test_that(".ensembleAssertCv reports the fold count it actually saw", { }) # --------------------------------------------------------------------------- -# The weight SCALE declaration +# The weight SCALE record # # `weight_standardized` is published alongside every weight, and it cannot be # recovered from the numbers: the standardized-to-raw conversion is a # per-variant factor 1/sqrt(2*af*(1-af)), so the two scales differ by an # allele-frequency-dependent amount at every variant and neither is -# recognisable on its own. The pipeline hardcoded FALSE, so an -# individual-level run on genotypes the caller HAD standardized published the -# opposite of the truth with no way to say so. fineMappingPipeline() takes the -# same argument for the same reason -- a posterior effect IS a weight. +# recognisable on its own. The pipelines therefore record it rather than take +# it as an argument: from the residualization settings on individual-level +# data, and always standardized on summary statistics. # --------------------------------------------------------------------------- -test_that("twasWeightsPipeline(QtlDataset) records the standardized scale", { - qd <- .tp_makeQtlDataset() - exec( - local_mocked_bindings, - !!!c( - list(extractBlockGenotypes = .tp_mockExtractor()), - .tp_mockIndividualWeights(), - list(.package = "pecotmr") - ) - ) - res <- suppressMessages(suppressWarnings(twasWeightsPipeline( - qd, - methods = "lasso", - cisWindow = 1000L, - estimatePi = FALSE, - verbose = 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. - expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) -}) - test_that("a summary-statistics run records the standardized scale itself", { # The RSS likelihood is written in standardized units, so the scale is not # the caller's to declare there -- the method has no such argument, and @@ -4810,8 +4495,8 @@ test_that("a summary-statistics run records the standardized scale itself", { expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) }) -test_that("the TWAS genotype scale also comes from the accessor", { - qd <- .tp_makeQtlDataset() +test_that("twasWeightsPipeline(QtlDataset) records the accessor's scale", { + qd <- .tp_makeQtlDataset(traits = "ENSG_A") exec( local_mocked_bindings, !!!c( @@ -4832,7 +4517,10 @@ test_that("the TWAS genotype scale also comes from the accessor", { ))) unique(as.logical(S4Vectors::mcols(res)$standardized)) } + # Derived, not declared: by default genotypes are standardized on the way + # to every fitter, so there is nothing for a caller to say ... expect_true(recorded()) + # ... and turning the scaling off is recorded too. expect_false(recorded(scaleResiduals = FALSE)) }) @@ -4925,7 +4613,7 @@ test_that("MultiStudyQtlDataset: joint fits get every caller setting", { 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) + expect_equal(ind$args$genotypeFilter$mafCutoff, 0.05) ss <- .capturedCall(cap, "sumstats") expect_equal(ss$config$fitRetention, "full") expect_equal(ss$config$dataType, "rnaseq") @@ -4957,3 +4645,274 @@ test_that("refuses full-data weights from a CV-only fineMappingResult", { fitFullData = FALSE )) }) + +# =========================================================================== +# Per-row LD references +# =========================================================================== + +test_that("a multivariate TWAS group refuses contexts on two LD references", { + # mr.mash fits a (study, trait)'s contexts together against one LD + # matrix, so rows on different references cannot share the fit. + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(100L * (1:5), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = sprintf("chr1:%d:A:G", 100L * (1:5)), + A1 = "A", + A2 = "G", + Z = c(6, 5.5, 1, 0.5, 0.2), + N = 1000L + ) + ids <- sprintf("chr1:%d:A:G", 100L * (1:5)) + ldm <- function(rho) { + LdMatrix(`dimnames<-`(rho^abs(outer(1:5, 1:5, "-")), list(ids, ids))) + } + ss <- QtlSumStats( + studyName = c("S", "S"), + context = c("c1", "c2"), + trait = c("t1", "t1"), + entry = list(gr, gr), + genome = "hg19", + ldReference = list(ldm(0.1), ldm(0.95)), + qcOptions = list(step1 = "ok") + ) + expect_error( + suppressMessages(twasWeightsPipeline(ss, methods = "mrmash")), + "a joint fit uses one LD matrix" + ) +}) + +test_that("twasWeightsPipeline(QtlSumStats) lays a cisWindow around traitPos", { + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + ) + # The entry's variants sit every 100 bp from chr1:100 to chr1:800 and the + # trait at chr1:400, so the fit keeps the variants within `cisWindow` of + # it; with no window it keeps them all. + ss <- .tp_makeQtlSumStats(traitPos = GenomicRanges::GRanges("chr1:400")) + keptIds <- function(cisWindow) { + res <- suppressMessages(twasWeightsPipeline( + ss, + methods = "lasso", + cisWindow = cisWindow, + verbose = 0 + )) + variantIds( + res, + studyName = "s1", + context = "c1", + trait = "t1", + method = "lasso" + ) + } + expect_equal(keptIds(150), sprintf("chr1:%d:A:G", c(300L, 400L, 500L))) + expect_equal(keptIds(0), "chr1:400:A:G") + expect_equal(keptIds(NULL), sprintf("chr1:%d:A:G", 100L * (1:8))) + # A tuple without a trait position has no window to lay. + expect_error( + twasWeightsPipeline(.tp_makeQtlSumStats(), cisWindow = 1000), + "twasWeightsPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) + # The selection is parsed before the window is laid, so naming a context + # reaches the same check rather than failing on the unparsed selection. + expect_error( + twasWeightsPipeline( + .tp_makeQtlSumStats(), + contexts = "c1", + cisWindow = 1000 + ), + "twasWeightsPipeline: `cisWindow` is laid around each tuple's trait", + fixed = TRUE + ) +}) + +test_that("twasWeightsPipeline(QtlSumStats) records traitPos and its window", { + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + ) + # A per-tuple fit's row carries its input's trait position and the window + # the cisWindow laid around it, as a joint fit's row does. + ss <- .tp_makeQtlSumStats(traitPos = GenomicRanges::GRanges("chr1:400")) + res <- suppressMessages(twasWeightsPipeline( + ss, + methods = "lasso", + cisWindow = 150, + verbose = 0 + )) + tp <- traitPosition(res) + rg <- genomicRegion(res) + expect_equal( + as.character(GenomicRanges::seqnames(c(tp, rg))), + c("chr1", "chr1") + ) + expect_equal(GenomicRanges::start(tp), 400L) + expect_equal( + c(GenomicRanges::start(rg), GenomicRanges::end(rg)), + c(250L, 550L) + ) +}) + +test_that("twasWeightsPipeline refuses a phenotype QC its fits cannot take", { + keep <- PhenotypeFilterParam(naAction = "keep") + expect_error( + twasWeightsPipeline( + .tp_makeQtlDataset(), + methods = "lasso", + phenotypeFilterParam = keep + ), + "twasWeightsPipeline: naAction = \"keep\" is not available" + ) + expect_error( + twasWeightsPipeline( + .tp_makeMultiStudy(), + methods = "lasso", + phenotypeFilterParam = keep + ), + "naAction = \"keep\" is not available" + ) +}) + +# =========================================================================== +# Narrowed fine-mapping rows: their fits are reused whole, which warns once +# =========================================================================== + +# The stub fine-mapping result with its rows narrowed to two of their three +# variants. +.tp_narrowedFineMapping <- function(...) { + endoapply(.tp_makeStubFineMappingResult(...), utils::head, 2L) +} + +test_that("each twasWeightsPipeline method warns about narrowed fits", { + qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + fromDataset <- .fitCoverageCondition(twasWeightsPipeline( + qd, + methods = "lasso", + fineMappingResult = .tp_narrowedFineMapping() + )) + expect_s3_class(fromDataset, "pecotmrFitCoverage") + expect_match( + conditionMessage(fromDataset), + "twasWeightsPipeline\\(\\): 1 row" + ) + fromSumStats <- .fitCoverageCondition(twasWeightsPipeline( + .tp_makeQtlSumStats(), + methods = "lasso", + fineMappingResult = .tp_narrowedFineMapping( + studyName = "s1", + contexts = "c1", + traits = "t1" + ) + )) + expect_s3_class(fromSumStats, "pecotmrFitCoverage") + fromStudies <- .fitCoverageCondition(twasWeightsPipeline( + .tp_makeMultiStudy(), + methods = "lasso", + fineMappingResult = .tp_narrowedFineMapping() + )) + expect_s3_class(fromStudies, "pecotmrFitCoverage") +}) + +# A stand-in for one study's run that warns about the rows the collection's +# run has already named. +.tp_warnAndReturn <- function(...) { + warn("twasWeightsPipeline(): narrowed", class = "pecotmrFitCoverage") + "ran" +} + +test_that("each study's run is muffled once the collection has warned", { + local_mocked_bindings( + twasWeightsPipeline = .tp_warnAndReturn, + .package = "pecotmr" + ) + qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") + expect_no_warning(out <- pecotmr:::.twasPerStudy(qd, list())) + expect_equal(out, "ran") + expect_no_warning( + out <- pecotmr:::.twasSumStats(.tp_makeQtlSumStats(), list()) + ) + expect_equal(out, "ran") +}) + +# =========================================================================== +# enet and ridge: glmnet on individual data, the penalized RSS solver on +# summary statistics, with the enet mixing settable on both +# =========================================================================== + +test_that("enet and ridge are registered for both input kinds", { + implFor <- pecotmr:::.twasMethodImplFor + expect_equal(implFor("enet", "QtlDataset"), "enetWeights") + expect_equal(implFor("enet", "QtlSumStats"), "enetRssWeights") + expect_equal(implFor("ridge", "QtlDataset"), "ridgeWeights") + expect_equal(implFor("ridge", "QtlSumStats"), "ridgeRssWeights") + expect_true(is_in( + "alpha", + pecotmr:::.twasChainAccepted("enet", "QtlSumStats") + )) + expect_equal( + pecotmr:::.twasTokensFromMethodList(list(ridge_weights = list())), + "ridge" + ) + expect_true(all(is_in( + c("enet", "ridge"), + pecotmr:::.twasFullDetailTokens("QtlSumStats") + ))) +}) + +test_that("the enet mixing reaches the individual-level wrapper", { + seen <- NULL + mocks <- list( + extractBlockGenotypes = .tp_mockExtractor(), + enetWeights = function( + X, + y, + alpha = 0.5, + methodArgs = GlmnetOptions() + ) { + seen <<- alpha + rep(0, ncol(X)) + } + ) + exec(local_mocked_bindings, !!!c(mocks, list(.package = "pecotmr"))) + res <- suppressMessages(twasWeightsPipeline( + .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A"), + methods = list(enet = list(alpha = 0.3)), + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationParam = CrossValidationParam(folds = 0), + ensembleParam = EnsembleParam() + )) + expect_equal(seen, 0.3) + expect_setequal(methodNames(res), "enet") +}) + +test_that("enet and ridge run on summary statistics, alpha set per method", { + local_mocked_bindings( + extractBlockGenotypes = .tp_mockExtractor(), + .package = "pecotmr" + ) + res <- suppressMessages(suppressWarnings(twasWeightsPipeline( + .tp_makeQtlSumStats(), + methods = list(lasso = list(), enet = list(alpha = 1), ridge = list()), + verbose = 0 + ))) + expect_setequal(methodNames(res), c("lasso", "enet", "ridge")) + # At alpha = 1 the elastic net is the lasso, so the two rows agree. + rowOf <- function(m) { + weights(res, studyName = "s1", context = "c1", trait = "t1", method = m) + } + expect_equal(as.numeric(rowOf("enet")), as.numeric(rowOf("lasso"))) + expect_true(all(rowOf("ridge") != 0)) +}) diff --git a/tests/testthat/test_twasWeightsRow.R b/tests/testthat/test_twasWeightsRow.R index a02b2b54..8c6e5741 100644 --- a/tests/testthat/test_twasWeightsRow.R +++ b/tests/testthat/test_twasWeightsRow.R @@ -1,9 +1,19 @@ -# Tests for R/TwasWeightsRow.R +# Tests for R/twasWeightsRow.R # === Tests migrated from test_s4Constructors.R (TwasWeightsRow) === +test_that("as(row, 'GRanges') carries the weights", { + row <- TwasWeightsRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + weights = c(0.4, -0.2) + ) + gr <- as(row, "GRanges") + expect_s4_class(gr, "GRanges") + expect_identical(gr$weight, c(0.4, -0.2)) +}) + test_that("TwasWeightsRow: constructor and accessors round-trip", { - e <- twasWeightsRow( + e <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), weights = c(0.1, -0.2, 0.05), methodFits = list(model = "lasso"), @@ -24,7 +34,7 @@ test_that("TwasWeightsRow: constructor and accessors round-trip", { }) test_that("TwasWeightsRow: resolveWeights returns the aligned (variantIds, weights) pair", { - e <- twasWeightsRow( + e <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), weights = c(0.1, -0.2, 0.05) ) @@ -35,7 +45,7 @@ test_that("TwasWeightsRow: resolveWeights returns the aligned (variantIds, weigh ) expect_equal(wr$weights, c(0.1, -0.2, 0.05)) # length mismatch (defensive) -> empty - e2 <- twasWeightsRow( + e2 <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, -0.2) ) @@ -47,14 +57,14 @@ test_that("TwasWeightsRow: resolveWeights returns the aligned (variantIds, weigh test_that("TwasWeightsRow: standardized is coerced via isTRUE() semantics", { # isTRUE() only returns TRUE for a length-1 logical TRUE. Non-TRUE # input lands as FALSE (the safe default for the standardized flag). - e_logical <- twasWeightsRow( + e_logical <- TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.1, weightStandardized = TRUE ) expect_true(isTRUE(weightStandardized(e_logical))) - e_default <- twasWeightsRow( + e_default <- TwasWeightsRow( variantIds = "chr1:100:A:G", weights = 0.1, weightStandardized = "yes-please" @@ -65,7 +75,7 @@ test_that("TwasWeightsRow: standardized is coerced via isTRUE() semantics", { test_that("TwasWeightsRow: validity rejects matrix weights with wrong nrow", { expect_error( - twasWeightsRow( + TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = matrix(0, nrow = 5, ncol = 1) ), @@ -73,40 +83,22 @@ test_that("TwasWeightsRow: validity rejects matrix weights with wrong nrow", { ) }) -# =========================================================================== -# QtlFineMappingResult -# =========================================================================== - -test_that("TwasWeights: rejects non-TwasWeightsRow rows", { +test_that("TwasWeightsRow: rejects mismatched variantIds/weights lengths", { + # The weights are per-variant mcols on the entry's element now, so a + # length mismatch cannot be represented. It is refused at construction + # rather than producing a gene that gets silently dropped downstream. expect_error( - TwasWeights( - studyName = "s1", - context = "c1", - trait = "t1", - method = "lasso", - entry = list("not_an_entry") + TwasWeightsRow( + variantIds = sprintf("chr1:%d:G:A", 100L * 1:5), + weights = c(0.1, 0.2, 0.3) ), - "must be a TWAS-weight row" + "length\\(weights\\) is 3 but 5 variants were supplied" ) }) - -test_that("TwasWeights: validity does not recurse on key subset (#546)", { - # Building the tuple-uniqueness key via `object[, keyCols]` preserves the - # TwasWeights class while dropping the required `entry` column; older - # S4Vectors revalidates that intermediate and fails with "missing columns". - e <- .sc_makeTwasWeightsRow(p = 5L) - res <- TwasWeights( - studyName = "s1", - context = "c1", - trait = "t1", - method = "lasso", - entry = list(e) - ) - expect_s4_class(res, "TwasWeights") - expect_true(validObject(res)) -}) - +# =========================================================================== +# TwasWeights +# =========================================================================== # === Tests migrated from test_showMethods.R (TwasWeightsRow) === @@ -119,7 +111,7 @@ test_that("show.TwasWeightsRow reports standardized flag and CV availability", { ))) expect_true(any(grepl("CV performance: TRUE", out))) - e_no_cv <- twasWeightsRow( + e_no_cv <- TwasWeightsRow( variantIds = c("chr1:100:A:G", "chr1:200:A:G"), weights = c(0.1, 0.2) ) @@ -134,12 +126,12 @@ test_that("show.TwasWeightsRow reports standardized flag and CV availability", { # that rejects ids carrying no coordinates was never executed. # =========================================================================== -test_that("variantIds that encode no coordinates are rejected", { +test_that("variantIds that encode no coordinates are rejected by name", { # An id is a rendering of the variant's range and alleles; "v1" names # nothing, and the failure should bite here rather than later when the # entry is turned into a ranged element. - expect_error( - twasWeightsRow( + err <- tryCatch( + TwasWeightsRow( variantIds = c("chr1:100:A:G", "v1", "v2"), weights = c(0.1, -0.2, 0.05), methodFits = list(model = "lasso"), @@ -147,30 +139,18 @@ test_that("variantIds that encode no coordinates are rejected", { weightStandardized = TRUE, weightsDataType = "expression" ), - "do not encode coordinates" - ) -}) - -test_that("the identity message names the offenders", { - err <- tryCatch( - twasWeightsRow( - variantIds = c("rsX", "rsY"), - weights = c(0.1, -0.2), - methodFits = list(), - cvResult = list(), - weightStandardized = TRUE, - weightsDataType = "expression" - ), error = function(e) conditionMessage(e) ) - expect_match(err, "2 of 2") - expect_match(err, "rsX, rsY") + expect_match(err, "do not encode coordinates") + # The message counts and names the offenders. + expect_match(err, "2 of 3") + expect_match(err, "v1, v2") }) test_that("an empty variant set is allowed", { # Emptiness is a separate concern from malformedness: there is nothing to # parse, so the coordinate rule has nothing to say. - e <- twasWeightsRow( + e <- TwasWeightsRow( variantIds = character(0), weights = numeric(0), methodFits = list(), diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 1f90fc78..1d4fc9e6 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -7,22 +7,25 @@ context("variantId") test_that("parseVariantId: canonical colon format with chr prefix", { res <- parseVariantId(c("chr1:100:A:G", "chr2:200:T:C")) expect_s3_class(res, "data.frame") - expect_equal(res$chrom, c("1", "2")) + expect_equal(res$chrom, c("chr1", "chr2")) expect_equal(res$pos, c(100L, 200L)) expect_equal(res$A2, c("A", "T")) expect_equal(res$A1, c("G", "C")) + expect_equal(attr(res, "convention")$alleleSep, ":") }) test_that("parseVariantId: canonical colon format without chr prefix", { res <- parseVariantId(c("1:100:A:G", "2:200:T:C")) - expect_equal(res$chrom, c("1", "2")) + expect_equal(res$chrom, c("chr1", "chr2")) expect_equal(res$pos, c(100L, 200L)) + expect_equal(res$A2, c("A", "T")) + expect_equal(res$A1, c("G", "C")) expect_equal(attr(res, "convention")$hasChr, FALSE) }) test_that("parseVariantId: underscore separator format", { res <- parseVariantId(c("chr1_100_A_G", "1_200_T_C")) - expect_equal(res$chrom, c("1", "1")) + expect_equal(res$chrom, c("chr1", "chr1")) expect_equal(res$pos, c(100L, 200L)) expect_equal(res$A2, c("A", "T")) expect_equal(res$A1, c("G", "C")) @@ -30,7 +33,7 @@ test_that("parseVariantId: underscore separator format", { test_that("parseVariantId: mixed colon-underscore format", { res <- parseVariantId("chr1:100_A_G") - expect_equal(res$chrom, "1") + expect_equal(res$chrom, "chr1") expect_equal(res$pos, 100L) expect_equal(res$A2, "A") expect_equal(res$A1, "G") @@ -39,7 +42,10 @@ test_that("parseVariantId: mixed colon-underscore format", { test_that("parseVariantId: strips build suffix", { res <- parseVariantId(c("chr1:100:A:G:b38", "chr1:200:T:C_b37")) + # The suffix is dropped, not carried as a fifth column. + expect_equal(colnames(res), c("chrom", "pos", "A2", "A1")) expect_equal(res$pos, c(100L, 200L)) + expect_equal(res$A2, c("A", "T")) expect_equal(res$A1, c("G", "C")) expect_equal(attr(res, "convention")$hasBuild, TRUE) }) @@ -51,17 +57,18 @@ test_that("parseVariantId: convention attribute records hasChr", { expect_equal(attr(no_chr, "convention")$hasChr, FALSE) }) -test_that("parseVariantId: data.frame input with chrom/pos/A2/A1 returns as-is", { +test_that("parseVariantId: a chrom/pos/A2/A1 frame is read in UCSC style", { df <- data.frame( - chrom = "chr1", - pos = 100L, - A2 = "A", - A1 = "G", + chrom = c("chr1", "2"), + pos = c(100, 200), + A2 = c("A", "C"), + A1 = c("G", "T"), stringsAsFactors = FALSE ) res <- parseVariantId(df) - expect_equal(res$chrom, "1") - expect_equal(res$pos, 100L) + # A bare chromosome gains the prefix; a double position becomes integer. + expect_equal(res$chrom, c("chr1", "chr2")) + expect_equal(res$pos, c(100L, 200L)) expect_equal(attr(res, "convention")$hasChr, TRUE) }) @@ -75,46 +82,14 @@ test_that("parseVariantId: data.frame input with >=4 columns assigns positional stringsAsFactors = FALSE ) res <- parseVariantId(df) - expect_equal(res$chrom, "1") + # The first four columns are renamed; the rest pass through. + expect_equal(names(res), c("chrom", "pos", "A2", "A1", "extra")) + expect_equal(res$chrom, "chr1") expect_equal(res$pos, 100L) expect_equal(res$A2, "A") expect_equal(res$A1, "G") }) -# =========================================================================== -# normalizeVariantId -# =========================================================================== - -test_that("normalizeVariantId: canonical output adds chr prefix by default", { - res <- normalizeVariantId(c("1:100:A:G", "2:200:T:C")) - expect_equal(res, c("chr1:100:A:G", "chr2:200:T:C")) -}) - -test_that("normalizeVariantId: chrPrefix = FALSE strips the chr prefix", { - res <- normalizeVariantId( - c("chr1:100:A:G", "chr2:200:T:C"), - chrPrefix = FALSE - ) - expect_equal(res, c("1:100:A:G", "2:200:T:C")) -}) - -test_that("normalizeVariantId: convention argument preserves the input format", { - ids <- c("chr1:100_A_G", "chr2:200_T_C") - conv <- attr(parseVariantId(ids), "convention") - res <- normalizeVariantId(c("1:100:A:G", "2:200:T:C"), convention = conv) - expect_equal(res, c("chr1:100_A_G", "chr2:200_T_C")) -}) - -test_that("normalizeVariantId: round-trips underscore-only input", { - res <- normalizeVariantId("1_100_A_G") - expect_equal(res, "chr1:100:A:G") -}) - -test_that("normalizeVariantId: strips build suffix and re-emits canonical", { - res <- normalizeVariantId("chr1:100:A:G:b38") - expect_equal(res, "chr1:100:A:G") -}) - # =========================================================================== # .repairVariantIds # =========================================================================== @@ -182,120 +157,28 @@ test_that(".repairVariantIds: non-DNA alleles on both sides are still kept", { expect_equal(out, ids) }) -# =========================================================================== -# parseRegion -# =========================================================================== - -test_that("parseRegion: canonical chr:start-end string", { - res <- parseRegion("chr1:100-200") - expect_s3_class(res, "data.frame") - expect_equal(res$chrom, "1") - expect_equal(res$start, 100L) - expect_equal(res$end, 200L) -}) - -test_that("parseRegion: handles X chromosome", { - res <- parseRegion("chrX:1000-2000") - expect_equal(res$chrom, "X") - expect_equal(res$start, 1000L) - expect_equal(res$end, 2000L) -}) - -test_that("parseRegion: accepts the underscore form its docs advertise", { - # LD-block / region ids are spelled chr_start_end; the docstring always - # claimed this worked while the regex rejected it. - expect_identical( - parseRegion("chr1_100_200"), - parseRegion("chr1:100-200") - ) - expect_identical( - parseRegion("chr22_49355984_50799822"), - parseRegion("chr22:49355984-50799822") - ) -}) - -test_that("parseRegion: accepts the mitochondrial contig", { - # canonChrom() exists to normalize MT/M, which the old regex made - # unreachable by erroring first. - res <- parseRegion("chrMT:10-20") - expect_identical(as.integer(res$start), 10L) - expect_identical(as.integer(res$end), 20L) -}) - -test_that("parseRegion: rejects malformed input", { - expect_error(parseRegion("notARegion"), "format must be") - expect_error(parseRegion("1:100:200"), "format must be") - # mixed spellings are not a third format - expect_error(parseRegion("chr1:100_200"), "format must be") - expect_error(parseRegion("chr1_100-200"), "format must be") -}) - -test_that("parseRegion: returns non-character input unchanged", { - df_in <- data.frame( - chrom = "1", - start = 100L, - end = 200L, - stringsAsFactors = FALSE - ) - expect_identical(parseRegion(df_in), df_in) - expect_identical(parseRegion(42L), 42L) -}) - -# =========================================================================== -# regionToDf -# =========================================================================== - -test_that("regionToDf: parses chrom_start_end LD region IDs", { - res <- regionToDf(c("1_100_200", "2_300_400")) - expect_equal(res$chrom, c("1", "2")) - expect_equal(res$start, c(100L, 300L)) - expect_equal(res$end, c(200L, 400L)) -}) - -test_that("regionToDf: strips chr prefix from chromosome", { - res <- regionToDf("chr5_1000_2000") - expect_equal(res$chrom, "5") -}) - -test_that("regionToDf: accepts colon/dash separators", { - res <- regionToDf("chr1:100-200") - expect_equal(res$chrom, "1") - expect_equal(res$start, 100L) - expect_equal(res$end, 200L) -}) - -test_that("regionToDf: honours custom column names", { - res <- regionToDf("1_10_20", colnames = c("seq", "from", "to")) - expect_equal(colnames(res), c("seq", "from", "to")) -}) - # =========================================================================== # classifyVariantType # =========================================================================== -test_that("classifyVariantType: identifies SNPs", { - expect_equal( - classifyVariantType(c("chr1:100:A:G", "chr1:200:C:T")), - c("SNP", "SNP") +test_that("classifyVariantType: identifies SNPs, indels and MNPs", { + ids <- c( + "chr1:100:A:G", + "chr1:200:ATG:A", + "chr1:300:A:ATG", + "chr1:400:AT:GC" ) -}) - -test_that("classifyVariantType: identifies insertions and deletions", { - expect_equal(classifyVariantType("chr1:100:A:ATG"), "insertion") - expect_equal(classifyVariantType("chr1:100:ATG:A"), "deletion") -}) - -test_that("classifyVariantType: identifies MNPs (equal-length multi-base)", { - expect_equal(classifyVariantType("chr1:100:AT:GC"), "MNP") + result <- classifyVariantType(ids) + expect_equal(result, c("SNP", "deletion", "insertion", "MNP")) }) test_that("classifyVariantType: accepts data.frame input with A2/A1 columns", { df <- data.frame( - A2 = c("A", "AT"), - A1 = c("G", "GC"), + A2 = c("A", "AT", "ATG"), + A1 = c("G", "GC", "A"), stringsAsFactors = FALSE ) - expect_equal(classifyVariantType(df), c("SNP", "MNP")) + expect_equal(classifyVariantType(df), c("SNP", "MNP", "deletion")) }) test_that("classifyVariantType: errors when given an unsupported input", { @@ -307,17 +190,9 @@ test_that("classifyVariantType: errors when given an unsupported input", { }) # =========================================================================== -# Tests migrated from test_misc.R (variant-id helpers) +# formatVariantId # =========================================================================== -test_that("Test formatVariantId", { - expect_equal( - formatVariantId(c(1, 1), c(123, 132), c("G", "A"), c("C", "T")), - c("chr1:123:G:C", "chr1:132:A:T") - ) -}) - - test_that("formatVariantId uses convention parameter automatically", { expect_equal(pecotmr:::formatVariantId(1, 100, "A", "G"), "chr1:100:A:G") @@ -346,7 +221,6 @@ test_that("formatVariantId uses convention parameter automatically", { ) }) - test_that("formatVariantId constructs canonical IDs", { expect_equal( pecotmr:::formatVariantId( @@ -367,85 +241,6 @@ test_that("formatVariantId constructs canonical IDs", { ) }) -# ============================================================================= -# ============================================================================= -# pvalHmp -# ============================================================================= - -test_that("parseRegion parses valid region string", { - result <- parseRegion("chr1:100-200") - expect_s3_class(result, "data.frame") - expect_equal(result$chrom, "1") - expect_equal(result$start, 100L) - expect_equal(result$end, 200L) -}) - - -test_that("parseRegion handles X chromosome", { - result <- parseRegion("chrX:500-1000") - expect_equal(result$chrom, "X") - expect_equal(result$start, 500L) - expect_equal(result$end, 1000L) -}) - - -test_that("parseRegion errors on invalid format", { - expect_error(parseRegion("1:100-200"), "format must be") - expect_error(parseRegion("chr1-100-200"), "format must be") - expect_error(parseRegion("chr1:abc-200"), "format must be") -}) - - -test_that("parseRegion returns non-string input unchanged", { - df <- data.frame(chrom = 1, start = 100, end = 200) - result <- parseRegion(df) - expect_identical(result, df) -}) - - -test_that("parseRegion returns non-single-string input unchanged", { - input <- c("chr1:100-200", "chr2:300-400") - result <- parseRegion(input) - expect_identical(result, input) -}) - -# ============================================================================= -# parseVariantId -# ============================================================================= - -test_that("parseVariantId parses single variant with chr prefix", { - result <- parseVariantId("chr1:12345:A:G") - expect_equal(result$chrom, "1") - expect_equal(result$pos, 12345L) - expect_equal(result$A2, "A") - expect_equal(result$A1, "G") - conv <- attr(result, "convention") - expect_true(conv$hasChr) - expect_equal(conv$alleleSep, ":") -}) - - -test_that("parseVariantId parses single variant without chr prefix", { - result <- parseVariantId("5:12345:A:G") - expect_equal(result$chrom, "5") - expect_equal(result$pos, 12345L) - expect_equal(result$A2, "A") - expect_equal(result$A1, "G") - conv <- attr(result, "convention") - expect_false(conv$hasChr) -}) - - -test_that("parseVariantId parses multiple variants", { - ids <- c("chr1:100:A:G", "chr2:200:C:T", "chr3:300:G:A") - result <- parseVariantId(ids) - expect_equal(nrow(result), 3) - expect_equal(result$chrom, c("1", "2", "3")) - expect_equal(result$pos, c(100L, 200L, 300L)) - expect_equal(result$A2, c("A", "C", "G")) - expect_equal(result$A1, c("G", "T", "A")) -}) - # ============================================================================= # detectVariantConvention # ============================================================================= @@ -472,6 +267,14 @@ test_that("detectVariantConvention detects chr prefix and allele separators", { expect_equal(conv5$alleleSep, "_") }) +test_that("detectVariantConvention returns defaults for all-NA input", { + result <- detectVariantConvention(c(NA, NA, NA)) + expect_false(result$hasChr) + expect_equal(result$alleleSep, ":") + expect_false(result$hasBuild) + expect_true(is.na(result$example)) +}) + # ============================================================================= # normalizeVariantId # ============================================================================= @@ -493,7 +296,6 @@ test_that("normalizeVariantId normalizes various formats", { ) }) - test_that("normalizeVariantId leaves unparseable ids (rsIDs) unchanged", { expect_equal( normalizeVariantId(c("rs123", "1:100:A:G", "chr2:200_C_T")), @@ -502,144 +304,6 @@ test_that("normalizeVariantId leaves unparseable ids (rsIDs) unchanged", { expect_equal(normalizeVariantId("rs1"), "rs1") # all-unparseable input }) -# ============================================================================= -# parseVariantId — id-format coverage (was the variantIdToDf alias) -# ============================================================================= - -test_that("parseVariantId handles colon-separated format", { - ids <- c("1:100:A:G", "2:200:C:T") - result <- parseVariantId(ids) - expect_equal(nrow(result), 2) - expect_equal(result$chrom, c("1", "2")) - expect_equal(result$pos, c(100L, 200L)) - expect_equal(result$A2, c("A", "C")) - expect_equal(result$A1, c("G", "T")) -}) - - -test_that("parseVariantId handles underscore-separated format", { - ids <- c("1:100_A_G", "2:200_C_T") - result <- parseVariantId(ids) - expect_equal(nrow(result), 2) - expect_equal(result$A2, c("A", "C")) -}) - - -test_that("parseVariantId strips chr prefix", { - ids <- c("chr1:100:A:G", "chr2:200:C:T") - result <- parseVariantId(ids) - expect_equal(result$chrom, c("1", "2")) -}) - - -test_that("parseVariantId handles data.frame input with named columns", { - df <- data.frame( - chrom = c("chr1", "2"), - pos = c(100, 200), - A2 = c("A", "C"), - A1 = c("G", "T") - ) - suppressWarnings(result <- parseVariantId(df)) - expect_equal(result$chrom, c("1", "2")) - expect_equal(result$pos, c(100L, 200L)) -}) - - -test_that("parseVariantId handles 5-part IDs with build suffix", { - ids <- c("chr1:100:A:G:b38", "chr2:200:T:C") - result <- parseVariantId(ids) - expect_equal(ncol(result), 4) - expect_equal(colnames(result), c("chrom", "pos", "A2", "A1")) - expect_equal(result$chrom, c("1", "2")) - expect_equal(result$A2, c("A", "T")) - expect_equal(result$A1, c("G", "C")) -}) - - -test_that("parseVariantId handles mixed 4/5-part IDs", { - ids <- c("1:100:A:G", "chr2:200:T:C:b38", "3:300:G:A:b37") - suppressWarnings(result <- parseVariantId(ids)) - expect_equal(nrow(result), 3) - expect_equal(ncol(result), 4) - expect_equal(result$A1, c("G", "C", "A")) -}) - -# ============================================================================= -# ============================================================================= -# ============================================================================= -# computeLd — uncovered branches -# ============================================================================= - -test_that("detectVariantConvention returns defaults for all-NA input", { - result <- detectVariantConvention(c(NA, NA, NA)) - expect_false(result$hasChr) - expect_equal(result$alleleSep, ":") - expect_false(result$hasBuild) - expect_true(is.na(result$example)) -}) - -# ============================================================================= -# parseVariantId — uncovered line 622 -# ============================================================================= - -test_that("parseVariantId handles data.frame with generic column names", { - df <- data.frame( - col1 = c("chr1", "chr2"), - col2 = c(100, 200), - col3 = c("A", "T"), - col4 = c("G", "C"), - stringsAsFactors = FALSE - ) - result <- parseVariantId(df) - expect_equal(names(result)[1:4], c("chrom", "pos", "A2", "A1")) - expect_equal(result$chrom, c("1", "2")) - expect_equal(result$pos, c(100L, 200L)) - expect_equal(result$A2, c("A", "T")) - expect_equal(result$A1, c("G", "C")) -}) - -# ============================================================================= -# classifyVariantType -# ============================================================================= - -test_that("classifyVariantType identifies SNPs", { - expect_equal(classifyVariantType("chr1:100:A:G"), "SNP") -}) - - -test_that("classifyVariantType identifies insertions", { - expect_equal(classifyVariantType("chr1:100:A:ATG"), "insertion") -}) - - -test_that("classifyVariantType identifies deletions", { - expect_equal(classifyVariantType("chr1:100:ATG:A"), "deletion") -}) - - -test_that("classifyVariantType identifies MNPs", { - expect_equal(classifyVariantType("chr1:100:AT:GC"), "MNP") -}) - - -test_that("classifyVariantType handles vector input", { - ids <- c( - "chr1:100:A:G", - "chr1:200:ATG:A", - "chr1:300:A:ATG", - "chr1:400:AT:GC" - ) - result <- classifyVariantType(ids) - expect_equal(result, c("SNP", "deletion", "insertion", "MNP")) -}) - - -test_that("classifyVariantType accepts data.frame input", { - df <- data.frame(A2 = c("A", "ATG"), A1 = c("G", "A")) - result <- classifyVariantType(df) - expect_equal(result, c("SNP", "deletion")) -}) - # =========================================================================== # canonChrom / chromOrder / non-autosomal chromosomes (string chrom contract) # =========================================================================== @@ -676,7 +340,7 @@ test_that("parseVariantId keeps non-autosomal chromosomes as strings", { "chrM:5:G:A", "chrY:9:C:T" )) - expect_equal(res$chrom, c("X", "X", "MT", "Y")) + expect_equal(res$chrom, c("chrX", "chrX", "chrM", "chrY")) expect_equal(res$pos, c(100L, 200L, 5L, 9L)) }) @@ -689,7 +353,8 @@ test_that("formatVariantId emits non-autosomal ids without 'chrNA'", { test_that("normalizeVariantId round-trips non-autosomal chromosomes", { expect_equal(normalizeVariantId("23:100:A:G"), "chrX:100:A:G") expect_equal(normalizeVariantId("chrX:100:A:G"), "chrX:100:A:G") - expect_equal(normalizeVariantId("chrM:5:G:A"), "chrMT:5:G:A") + expect_equal(normalizeVariantId("chrM:5:G:A"), "chrM:5:G:A") + expect_equal(normalizeVariantId("MT:5:G:A"), "chrM:5:G:A") }) test_that("chromOrder sorts autosomes then X/Y/MT", { @@ -697,13 +362,6 @@ test_that("chromOrder sorts autosomes then X/Y/MT", { expect_equal(as.character(sort(ord)), c("1", "2", "22", "X", "Y", "MT")) }) -test_that("regionToDf keeps chrom as a string and positions as integers", { - res <- regionToDf("chrX_1000_2000") - expect_equal(res$chrom, "X") - expect_type(res$start, "integer") - expect_equal(res$start, 1000L) -}) - # =========================================================================== # matchVariants -- allele-aware matcher (match on chrom/pos/ref/alt) # =========================================================================== @@ -873,15 +531,17 @@ test_that("harmonizeAlleles flipStrand = TRUE runs the strand-flip branch", { test_that("harmonizeAlleles complements colToComplement on an allele swap", { # target G/A is the ref/alt swap of ref A/G, so an effect-allele freq - # complements to 1 - af. - tgt <- .vid_df("1", 100, "G", "A", af = 0.3) + # complements to 1 - af while the signed colToFlip column is negated. + tgt <- .vid_df("1", 100, "G", "A", af = 0.3, z = 2) res <- pecotmr:::harmonizeAlleles( tgt, .vid_df("1", 100, "A", "G"), + colToFlip = "z", colToComplement = "af", matchMinProp = 0 ) expect_equal(res$harmonizedData$af, 0.7) + expect_equal(res$harmonizedData$z, -2) }) test_that("harmonizeAlleles errors when colToFlip / colToComplement are absent", { @@ -926,7 +586,7 @@ test_that("harmonizeAlleles errors on duplicate variant IDs when removeDups = FA .vid_df("1", 100, "A", "G"), matchMinProp = 0 ), - "Duplicated variant IDs" + "Duplicated variant IDs remain" ) }) @@ -939,7 +599,7 @@ test_that("harmonizeAlleles removeDups = TRUE drops duplicates with a warning", removeDups = TRUE, matchMinProp = 0 ), - "duplicate" + "Removed 1 duplicate" ) expect_equal(nrow(res$harmonizedData), 1L) }) @@ -1037,8 +697,110 @@ test_that("harmonizeAlleles counts what it kept, not what it joined", { expect_equal(counts$signFlip, 0L) }) +test_that("harmonizeAlleles surfaces sign/strand/dropped in qcCounts", { + # 4 shared positions: 100 exact, 200 sign-flip, 300 strand-flip (A/G + # unambiguous), 400 allele mismatch (dropped). + target <- data.frame( + chrom = c(1, 1, 1, 1), + pos = c(100, 200, 300, 400), + A2 = c("A", "A", "A", "A"), + A1 = c("G", "G", "G", "G"), + z = c(1, 2, 3, 4), + stringsAsFactors = FALSE + ) + ref <- data.frame( + chrom = c(1, 1, 1, 1), + pos = c(100, 200, 300, 400), + A2 = c("A", "G", "T", "C"), + A1 = c("G", "A", "C", "A"), + stringsAsFactors = FALSE + ) + res <- pecotmr:::harmonizeAlleles( + target, + ref, + colToFlip = "z", + matchMinProp = 0 + ) + # Default return shape unchanged. + expect_named(res, c("harmonizedData", "qcSummary")) + expect_equal(nrow(res$harmonizedData), 3L) + cnt <- attr(res, "qcCounts") + expect_false(is.null(cnt)) + expect_equal(cnt$considered, 4L) + expect_equal(cnt$signFlip, 1L) + expect_equal(cnt$strandFlip, 1L) + expect_equal(cnt$kept, 3L) + expect_equal(cnt$dropped, 1L) +}) + +test_that("harmonizeAlleles: accepts a bare variant-id vector as target", { + res <- pecotmr:::harmonizeAlleles( + c("chr1:100:A:G", "chr1:200:C:T"), + c("chr1:100:A:G", "chr1:200:C:T"), + matchMinProp = 0 + ) + expect_equal(nrow(res$harmonizedData), 2L) +}) + +test_that("harmonizeAlleles: strips a conflicting variant_id from target", { + target <- data.frame( + chrom = c(1, 1), + pos = c(100, 200), + A2 = c("A", "C"), + A1 = c("G", "T"), + variant_id = c("old1", "old2"), + z = c(1, 2), + stringsAsFactors = FALSE + ) + ref <- data.frame( + chrom = c(1, 1), + pos = c(100, 200), + A2 = c("A", "C"), + A1 = c("G", "T"), + stringsAsFactors = FALSE + ) + res <- pecotmr:::harmonizeAlleles( + target, + ref, + colToFlip = "z", + matchMinProp = 0 + ) + expect_equal(nrow(res$harmonizedData), 2L) + # The input variant_id was stripped; the returned id is rebuilt from QC'd alleles. + expect_false(any(c("old1", "old2") %in% res$harmonizedData$variant_id)) +}) + +test_that("harmonizeAlleles renames an empty target column to unnamed_N", { + # 5 columns whose first four are positional (NOT literally named + # chrom/pos/A2/A1), so harmonizeAlleles routes through parseVariantId -- + # which preserves the extra column -- rather than the select()-based path. + # The 5th column has an empty name, so the joined matchResult carries an + # empty-named column and .sanitizeNames() rewrites it to "unnamed_1". + target <- data.frame( + CHR = c(1, 1, 1), + POS = c(100, 200, 300), + ref = c("A", "C", "G"), + alt = c("G", "T", "A"), + extra = c(0.1, 0.2, 0.3), + stringsAsFactors = FALSE + ) + names(target)[5] <- "" + ref <- data.frame( + chrom = c(1, 1, 1), + pos = c(100, 200, 300), + A2 = c("A", "C", "G"), + A1 = c("G", "T", "A"), + stringsAsFactors = FALSE + ) + res <- pecotmr:::harmonizeAlleles(target, ref, matchMinProp = 0) + expect_equal(nrow(res$harmonizedData), 3L) + nm <- colnames(res$harmonizedData) + expect_false(any(nm == "" | is.na(nm))) # the empty name was repaired + expect_true(any(grepl("^unnamed_", nm))) # ... to an "unnamed_*" label +}) + # =========================================================================== -# withChrPrefix + asGranges error paths +# withChrPrefix # =========================================================================== test_that("withChrPrefix adds a lowercase chr prefix case-insensitively", { @@ -1048,22 +810,107 @@ test_that("withChrPrefix adds a lowercase chr prefix case-insensitively", { ) }) -test_that("asGranges errors on malformed input", { - expect_error(pecotmr:::asGranges(data.frame(foo = 1)), "must have columns") - expect_error(pecotmr:::asGranges(list(1)), "character vector or data.frame") +test_that("withChrPrefix spells chromosomes as UCSC does", { + expect_equal( + pecotmr:::withChrPrefix( + c("01", "23", "24", "x", "M", "MT", "chrM", "chrMT", NA) + ), + c("chr1", "chrX", "chrY", "chrX", "chrM", "chrM", "chrM", "chrM", NA) + ) + # A contig outside the standard set keeps its spelling behind the prefix. + expect_equal( + pecotmr:::withChrPrefix(c("chrUn_gl000192", "GL000192.1", "XY")), + c("chrUn_gl000192", "chrGL000192.1", "chrXY") + ) }) -test_that("asGranges (exported) converts region strings and data.frames", { - gr <- asGranges("chr1:100-200") - expect_s4_class(gr, "GRanges") - expect_equal(as.character(GenomicRanges::seqnames(gr)), "chr1") - expect_equal(GenomicRanges::start(gr), 100L) - expect_equal(GenomicRanges::end(gr), 200L) - # numeric chrom gets a chr prefix; data.frame input is accepted too - gr2 <- asGranges(data.frame(chrom = "2", start = 5, end = 9)) - expect_equal(as.character(GenomicRanges::seqnames(gr2)), "chr2") +test_that("withChrPrefix agrees with GenomeInfoDb's UCSC style", { + ncbi <- c(as.character(1:22), "X", "Y", "MT") + expect_identical( + pecotmr:::withChrPrefix(ncbi), + unname(GenomeInfoDb::mapSeqlevels(ncbi, "UCSC")) + ) + gr <- GenomicRanges::GRanges( + pecotmr:::withChrPrefix(ncbi), + IRanges::IRanges(1L, width = 1L) + ) + expect_identical(GenomeInfoDb::seqlevelsStyle(gr), "UCSC") +}) + +test_that(".ucscRanges renames to UCSC and keeps the rest", { + # Anything but ranges passes through for its caller to refuse. + expect_null(pecotmr:::.ucscRanges(NULL)) + expect_identical(pecotmr:::.ucscRanges("chr1"), "chr1") + ucsc <- GenomicRanges::GRanges("chr1", IRanges::IRanges(5L, width = 1L)) + expect_identical(pecotmr:::.ucscRanges(ucsc), ucsc) + gr <- GenomicRanges::GRanges( + c("1", "MT"), + IRanges::IRanges(c(100L, 5L), width = 1L, names = c("a", "b")), + strand = c("+", "-"), + SNP = c("rs1", "rs2") + ) + GenomeInfoDb::genome(gr) <- "hg19" + out <- pecotmr:::.ucscRanges(gr) + expect_identical( + as.character(GenomicRanges::seqnames(out)), + c("chr1", "chrM") + ) + expect_identical(names(out), c("a", "b")) + expect_identical(as.character(GenomicRanges::strand(out)), c("+", "-")) + expect_identical(out$SNP, c("rs1", "rs2")) + expect_identical(unname(GenomeInfoDb::genome(out)), c("hg19", "hg19")) }) +test_that(".ucscRanges merges two spellings of one chromosome", { + gr <- GenomicRanges::GRanges( + c("1", "chr1", "2"), + IRanges::IRanges(c(10L, 20L, 30L), width = 1L), + strand = c("+", "*", "-"), + SNP = c("a", "b", "c") + ) + GenomeInfoDb::genome(gr) <- "hg38" + out <- pecotmr:::.ucscRanges(gr) + expect_identical(GenomeInfoDb::seqlevels(out), c("chr1", "chr2")) + expect_identical( + as.character(GenomicRanges::seqnames(out)), + c("chr1", "chr1", "chr2") + ) + expect_identical(as.character(GenomicRanges::strand(out)), c("+", "*", "-")) + expect_identical(out$SNP, c("a", "b", "c")) + expect_identical(unname(GenomeInfoDb::genome(out)), c("hg38", "hg38")) +}) + +test_that(".ucscEntries renames every element and keeps a NULL one", { + out <- pecotmr:::.ucscEntries(list( + a = GenomicRanges::GRanges("22", IRanges::IRanges(1L, width = 1L)), + b = NULL + )) + expect_identical(names(out), c("a", "b")) + expect_identical(as.character(GenomicRanges::seqnames(out$a)), "chr22") + expect_null(out$b) +}) + +test_that(".ucscExperiment renames an experiment's rowRanges only", { + m <- matrix(1, 1L, 1L, dimnames = list("v", "s")) + plain <- SummarizedExperiment::SummarizedExperiment(list(x = m)) + expect_identical(pecotmr:::.ucscExperiment(plain), plain) + rse <- SummarizedExperiment::SummarizedExperiment( + list(x = m), + rowRanges = GenomicRanges::GRanges( + "X", + IRanges::IRanges(9L, width = 1L) + ) + ) + out <- pecotmr:::.ucscExperiment(rse) + expect_identical(GenomeInfoDb::seqlevels(out), "chrX") + expect_identical(SummarizedExperiment::assay(out), m) + expect_identical(pecotmr:::.ucscExperiment(out), out) +}) + +# =========================================================================== +# matchVariants: data.frame input +# =========================================================================== + test_that("matchVariants allowFlip = FALSE accepts data.frame input", { a <- .vid_df("1", 100, "A", "G") b <- .vid_df("1", 100, "A", "G") @@ -1085,15 +932,10 @@ test_that("matchVariants returns empty for unparseable data.frame input", { # matchVariants: a reference carrying both orientations of one variant # =========================================================================== -test_that("matchVariants drops a target matching both orientations", { +test_that("matchVariants drops a flip-pair target, whatever the row order", { # Two distinct indels at one position that are each other's allele flip is # rare but biologically real. A target then matches one exactly (+1) and # the other as a swap (-1), and nothing can say which it is. - panel <- c("chr1:100:A:AT", "chr1:100:AT:A") - expect_length(matchVariants("chr1:100:A:AT", panel)$idxA, 0L) -}) - -test_that("the drop does not depend on the reference's row order", { # The bug this replaces: `!duplicated()` kept whichever match came first, # so the SIGN -- and with it the effect direction -- was decided by the # panel's row order. @@ -1144,6 +986,9 @@ test_that("the rule applies to SNP flip pairs, not just indels", { expect_length(matchVariants("chr1:200:A:G", panel)$idxA, 0L) }) +# =========================================================================== +# Remaining helpers and argument guards +# =========================================================================== test_that("a convention without an allele separator keeps the default", { f <- pecotmr:::formatVariantId @@ -1264,26 +1109,3 @@ test_that("normalizeVariantId: argument guards fire", { "convention.*Must be of type 'list'" ) }) - -test_that("regionToDf: argument guards fire", { - expect_error(regionToDf(1L), "Must be of type 'character'") - expect_error( - regionToDf("1_100_200", colnames = c("a", "b")), - "colnames.*Must have length 3" - ) -}) - -test_that("asGranges leaves an already chr-prefixed chromosome alone", { - # The prefix is added only when absent; a frame that already carries it - # must not become "chrchr1". - gr <- asGranges(data.frame( - chrom = c("chr1", "chr2"), - start = c(100L, 200L), - end = c(150L, 250L), - stringsAsFactors = FALSE - )) - expect_identical( - as.character(GenomicRanges::seqnames(gr)), - c("chr1", "chr2") - ) -}) diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index 62f99d92..9c093c1a 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -87,9 +87,10 @@ res2 <- colocPipeline( attr(res2, "gwasFineMapping") ``` -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. +If the `QtlFineMappingResult` has LD references because it was run on +summary statistics, each of its rows must use the same LD reference as the +GWAS rows it overlaps. A QTL row with no LD reference, such as a fit to +individual-level data, is not checked. ## QTL FMR + pre-computed GWAS FMR @@ -106,6 +107,21 @@ windows. Ultimately this means that the variable selection in the QTL and GWAS fine-mapping will have been done over different variant sets, which may reduce the sensitivity for colocalizations, particuarly in areas with complex LD. +A QTL region that reaches more than one of a GWAS study's LD blocks is still +one colocalization, not one per block. Given a `GwasSumStats`, the blocks the +region reaches are stitched together and fine-mapped once. Given a +`GwasFineMappingResult`, their fits are collapsed into one fit over the +region, assuming no LD between blocks, so each block's effects keep to their +own block. Either way the result's `blockId` names the stretch the blocks +cover. + +So load every block a QTL region reaches. A region whose variants run past +the loaded blocks of a GWAS study it overlaps is an error when those blocks' +windows were given as the study's `region`: the variants past them lie in a +block that was not loaded. When the windows are only the span of the GWAS +variants, the variants past them may be ones the GWAS lacks, so more than one +in a row past a block is a warning. + ## Filtering effects fed into coloc `coloc::coloc.bf_bf` accepts one LBF matrix for the QTL and one for hte GWAS. @@ -132,7 +148,7 @@ colocPipeline( ## Enrichment-aware colocalisation (enloc mode) -Passing a per-`(gwasStudy, qtlContext)` enrichment table --- the output of +Passing a per-pair enrichment table --- the output of `qtlEnrichmentPipeline()` --- switches the pair from coloc to enloc. This is a port of `fastenloc`, not a reweighting of coloc: the priors are *derived* from the enrichment estimate rather than the baseline `p12` being scaled by @@ -277,8 +293,8 @@ The warning above is the diagnostic that rule produces: a within-credible-set sum above 1 means several GWAS credible sets are competing for one QTL signal. The value is clipped to 1, and the pair view shows which pairs were involved. -If you need the flat table the pipeline used to return, `as.data.frame(res)` -gives the pair view. +If you need the flat table the pipeline used to return, `colocPairs(res)` is +the pair view, as a `DataFrame`. # Session info diff --git a/vignettes/colocboost-pipeline.Rmd b/vignettes/colocboost-pipeline.Rmd index 422af3cc..8583ef0b 100644 --- a/vignettes/colocboost-pipeline.Rmd +++ b/vignettes/colocboost-pipeline.Rmd @@ -29,7 +29,7 @@ layered on top. It accepts inputs from the QTL input classes: | QTL input | What it is | |---|---| | `QtlDataset` | Single-study, individual-level: per-context residualized X/Y are extracted from the dataset | -| `QtlSumStats` | QTL summary statistics with a shared LD reference (must be QC'd) | +| `QtlSumStats` | QTL summary statistics, LD reference per row (must be QC'd) | | `MultiStudyQtlDataset` | One or more individual-level studies + optional embedded `QtlSumStats` | GWAS input (optional) is always a `GwasSumStats`, passed as the @@ -59,9 +59,12 @@ ColocBoost can run three different model flavours in one call. | Flag | Default | What | |---|---|---| | `xqtlColoc` | TRUE | QTL-only colocboost across the QTL contexts. | -| `jointGwas` | FALSE | Single non-focal colocboost model that stacks all QTL contexts/studies with every supplied GWAS study. | +| `jointGwas` | FALSE | All QTL outcomes with every GWAS study in one non-focal model. | | `separateGwas` | FALSE | One focal colocboost model per GWAS study (the GWAS is the focal outcome). | +The flags combine freely. With a single GWAS study, `jointGwas` and +`separateGwas` fit the same outcomes, one non-focal and one focal on the GWAS. + ## xQTL-only colocalization The default call runs colocboost over the contexts in the QTL data with no @@ -93,6 +96,13 @@ res2 <- colocboostPipeline( names(res2) ``` +Each GWAS study is one outcome: the rows of the study that the QTL data +overlap, joined. A study split by chromosome or LD block contributes only the +one or two rows the QTL region reaches, and QTL variants past those blocks are +checked as `colocPipeline()` checks them. The joint run is non-focal however +many GWAS studies it holds (colocboost's disease-agnostic mode); for a run +focal on a GWAS, use `separateGwas`. + ## QTL + GWAS (per-GWAS focal models) When you want one colocboost run per GWAS trait, with that trait as the @@ -123,6 +133,15 @@ resSs <- colocboostPipeline( ) ``` +Each row is matched against its own `ldReference`, so the GWAS need not use +the QTL side's reference. `ldReference()` on the result lists the references +used, each once, and the `ldReference` column of `colocBoostOutcomes()` names +the one behind each outcome. + +```{r sumstats-ld} +names(ldReference(resSs)) +``` + ## Multi-study individual-level ```{r multistudy} @@ -134,16 +153,18 @@ resMs <- colocboostPipeline( ) ``` -## Focal trait +## Focal outcome -`focalTrait` makes the xQTL-only run treat one specific trait as the -focal outcome: +`focalOutcome` makes one QTL outcome focal in the xQTL-only run. It names +the outcome by its `study`, `context` and `trait`, as many as it takes to +pick out one. The default, `NULL`, leaves that run non-focal. The joint run +is never focal, and each `separateGwas` run is focal on its own GWAS study. ```{r focal, eval=FALSE} colocboostPipeline( qtlDatasetExample, xqtlColoc = TRUE, - focalTrait = "ENSG_example" + focalOutcome = c(context = "brain", trait = "ENSG_example") ) ``` @@ -155,35 +176,31 @@ colocboostPipeline( gwasSumStats = gwasSumStatsS4Example, contexts = "brain", traitId = "ENSG_example", - region = NULL, # alternative to traitId+cisWindow + region = NULL, # alternative to traitId + cisWindow cisWindow = 5e5, # required with traitId - focalTrait = NULL, + focalOutcome = NULL, # a QTL outcome to make the xQTL-only run focal on xqtlColoc = TRUE, jointGwas = FALSE, separateGwas = FALSE, - # Forward to colocboost::colocboost - M = 10, - L = 5, - output_level = 1L + # Forwarded to colocboost::colocboost + methodArgs = ColocboostOptions(M = 10) ) ``` -Trait / context / region restrictions are pre-construction concerns on -the `QtlDataset` (`keepSamples`, `keepVariants`, the per-context -`SummarizedExperiment` row selection); the pipeline parameters above -are the per-call refinements. +Which traits, contexts and window to analyse are the pipeline parameters +above; which variants and samples to keep is `genotypeFilterParam`, as in +`fineMappingPipeline()`. ## QC requirements - **Individual-level (`QtlDataset` / `MultiStudyQtlDataset`)**: QC (MAF / MAC - / X-variance / per-sample missingness, sample / variant restrictions) lives - on the `QtlDataset` constructor and is applied lazily inside - `genotypes()` / `residualizedGenotypes()`. The pipeline does not run - a separate pass. + / X-variance / per-sample missingness, sample / variant restrictions) is + the pipeline's `genotypeFilterParam`, applied to each block of genotypes + it extracts. The dataset itself records no filter. - **Summary statistics (`QtlSumStats` / `GwasSumStats`)**: all variant filters, panel harmonization, LD-mismatch detection, and RAISS imputation live in [`summaryStatsQc()`](rss-qc.html). The pipeline rejects inputs - whose `qcInfo()` is empty. + whose `qcOptions()` is empty. # Session info diff --git a/vignettes/constructing-qtl-datasets.Rmd b/vignettes/constructing-qtl-datasets.Rmd index 49e2c86a..6a669004 100644 --- a/vignettes/constructing-qtl-datasets.Rmd +++ b/vignettes/constructing-qtl-datasets.Rmd @@ -17,6 +17,8 @@ knitr::opts_chunk$set( fig.width = 7, fig.height = 4.5 ) +hasRelatednessQc <- requireNamespace("plinkQC", quietly = TRUE) && + requireNamespace("igraph", quietly = TRUE) ``` ## Overview @@ -43,18 +45,18 @@ are one more: Alongside them the object keeps a `colData` naming every sample and a `sampleMap` recording which of them each experiment observes — so contexts -need not share a sample set — plus its own slots: +need not share a sample set — plus one slot of its own, `studyName`. The +genotype panel (a lazy PLINK1/PLINK2/VCF/GDS/BGEN source, read with +`readGenotypes()`) is the `genotype` experiment, whose dosage assay reads +through it. -* `study` — study identifier (length-1 character). -* `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, - applied at genotype-extraction time. +A `QtlDataset` holds data only. Which variants and samples an analysis +keeps (`GenotypeFilterParam`) and how it residualizes +(`ResidualizationParam`) are the pipelines' settings, applied to each block +they extract. To restrict a dataset to a set of samples, subset it: `x[, samples, ]` narrows -`colData` and `sampleMap` together, and keeps the class and its slots. The -`keepSamples` constructor argument is shorthand for the same thing. +`colData` and `sampleMap` together, and keeps the class and its slot. There are two ways to build a `QtlDataset`: @@ -175,18 +177,16 @@ readr::write_tsv(manifest, manifestPath) qd <- loadQtlDatasetFromManifest(manifestPath) ``` -The QC thresholds are ordinary arguments (they are stored as lazy filters, not -applied at load), for example: +Loading applies no QC: the dataset holds the data as read, and a pipeline +filters each block it extracts with its `genotypeFilterParam`, for example: ```{r qtl-manifest-qc} -qdFiltered <- loadQtlDatasetFromManifest( - manifest, - genotypeFilterParam = GenotypeFilterParam( - mafCutoff = 0.01, - imissCutoff = 0.05, - keepIndel = FALSE - ) +qcFilter <- GenotypeFilterParam( + mafCutoff = 0.01, + imissCutoff = 0.05, + keepIndel = FALSE ) +# fineMappingPipeline(qd, methods = "susie", genotypeFilterParam = qcFilter) ``` ## Constructing a QtlDataset manually @@ -272,12 +272,12 @@ A MultiStudyQtlDataset can be manually constructed by building a named list of msdManual <- MultiStudyQtlDataset( qtlDatasets = list(StudyA = qd, StudyB = qdManual) ) -names(qtlDatasets(msdManual)) +names(msdManual) ``` To attach a summary-only study, pass a `QtlSumStats` object to the `sumStats` -argument. For the manifest form, supply `sumStatsManifest`, `genome`, and -`ldReference`. +argument. For the manifest form, supply `sumStatsManifest` and `genome`, plus +`ldReference` unless the manifest gives each row an `ldReferencePath`. ## Excluding related samples @@ -290,7 +290,7 @@ dataset is built — the pipelines do not model it. `filterRelatedness()` takes a kinship table — one row per pair, the shape PLINK's `--genome` or KING emits — and returns the individuals to **drop**: -```{r relatedness, eval = requireNamespace("plinkQC", quietly = TRUE) && requireNamespace("igraph", quietly = TRUE)} +```{r relatedness, eval = hasRelatednessQc} relatedness <- data.frame( IID1 = c(samples[1], samples[3], samples[5]), IID2 = c(samples[2], samples[4], samples[6]), @@ -314,7 +314,11 @@ is described with `RelatednessColumnsParam()`: ```r filterRelatedness( relatedness, - columns = RelatednessColumnsParam(iid1 = "ID1", iid2 = "ID2", value = "KINSHIP") + columns = RelatednessColumnsParam( + iid1 = "ID1", + iid2 = "ID2", + value = "KINSHIP" + ) ) ``` @@ -322,10 +326,9 @@ Building the description rather than passing a bare list means a misspelled field is an error at the call site instead of a default silently left in place. -The exclusion list is not applied for you — feed it to `keepSamples`, the -constructor argument this vignette introduced above, or subset an existing -dataset with `qd[, unrelated, ]`. Both narrow `colData` and `sampleMap` -together. +The exclusion list is not applied for you — subset the dataset with +`qd[, unrelated, ]`, which narrows `colData` and `sampleMap` together, or +hand it to a pipeline as `GenotypeFilterParam(keepSamples = unrelated)`. `analysisType` changes what is being maximised. The default, `"maximizeUnrelated"`, keeps the largest unrelated set. `"maximizeCases"` @@ -338,16 +341,19 @@ the chunk above is skipped when they are not installed. ## Next steps -Once built, the accessors extract data lazily, applying the stored QC filters -at extraction time: +Once built, the accessors read the data lazily. To read part of it, subset +the dataset first: ```{r accessors} studyName(qd) contexts(qd) -# Cis genotypes around a trait (+/- a window), QC applied on the fly: -dim(genotypes(qd, traitId = "GENE1", cisWindow = 1e6)) -# Phenotype matrix for one context: -dim(SummarizedExperiment::assay(molecularTraits(qd, contexts = "Muscle"))) +# Cis genotypes around a trait (+/- 1 Mb): narrow to the window, then read +cisWindow <- traitPosition(qd, "GENE1") + 1e6 +dim(genotypes(qd[cisWindow, , ])) +# Phenotypes for one context: a list keyed by context, each element the +# context's SummarizedExperiment as stored. +muscle <- molecularTraits(qd, context = "Muscle")[["Muscle"]] +dim(SummarizedExperiment::assay(muscle)) ``` `QtlDataset` and `MultiStudyQtlDataset` are direct inputs to diff --git a/vignettes/constructing-sumstats.Rmd b/vignettes/constructing-sumstats.Rmd index 9ce9a8b8..9ef0d48e 100644 --- a/vignettes/constructing-sumstats.Rmd +++ b/vignettes/constructing-sumstats.Rmd @@ -33,15 +33,18 @@ per-variant statistics — annotated by an identity tuple: Every `entry` GRanges must carry these `mcols`: `SNP`, `A1` (effect / dosage-counted allele), `A2` (other allele), `Z`, `N`; optionally `MAF`, -`INFO`, `BETA`, `SE`, `P`. Two settings apply to the whole collection and are -stored in slots, not columns: +`INFO`, `BETA`, `SE`, `P`. Two further settings are not variant columns: -* `genome` — the build label (e.g. `"GRCh38"`). +* `genome` — the build label (e.g. `"GRCh38"`), one for the whole + collection. * `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)). + [LD reference vignette](ld-infrastructure.html)). One reference serves + every row; pass a list with one per row (one per study for + `GwasSumStats`) when they sit on different references. Each distinct + reference is stored once, and `ldReference()` lists them. Optional per-row columns: `varY` (phenotype variance) and, for case/control GWAS, `nCase` / `nControl`. @@ -54,11 +57,11 @@ GWAS, `nCase` / `nControl`. * **Manually** — build the `entry` GRanges yourself and call the `GwasSumStats()` / `QtlSumStats()` constructor. -> **The loaders run no QC.** They build the raw collection with an empty -> `qcInfo` slot. Allele harmonization, MAF/INFO/N filtering, and LD-mismatch QC +> **The loaders run no QC.** They build the raw collection with empty +> `qcOptions()`. Allele harmonization, MAF/INFO/N filtering, and LD-mismatch QC > are a separate, mandatory step — `summaryStatsQc()` — documented in the > *Quality Control for GWAS and QTL Summary Statistics* vignette. Downstream -> pipelines reject collections whose `qcInfo` is empty. +> pipelines reject collections whose `qcOptions()` is empty. ```{r load-packages} library(pecotmr) @@ -104,9 +107,10 @@ readr::write_tsv(sumstatsDf, gwasTsv) ## GwasSumStats from a manifest -The GWAS manifest has **one row per study**. `genome` and `ldReference` are -collection-level, so they are supplied as arguments (or as constant -`genome` / `ldReferencePath` columns). +The GWAS manifest has **one row per study**. `genome` is collection-level, so +it is supplied as an argument (or as a constant `genome` column). The LD +reference is per study: pass one `ldReference` argument for every study, or +give each row its own `ldReferencePath`. | Column | Required | Meaning | |---|---|---| @@ -115,7 +119,8 @@ 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`, `ldReferencePath` | single-valued | may instead be arguments | +| `genome` | single-valued | may instead be an argument | +| `ldReferencePath` | no | this study's LD reference (or the argument) | ```{r gwas-from-manifest} gwasManifest <- data.frame( @@ -180,7 +185,8 @@ 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`, `ldReferencePath` | single-valued | may instead be arguments | +| `genome` | single-valued | may instead be an argument | +| `ldReferencePath` | no | this row's LD reference (or the argument) | ```{r qtl-from-manifest} qtlManifest <- data.frame( @@ -299,9 +305,10 @@ length(gwsMapped[[1]]) If a `region` is supplied and the sumstats file is **compressed with bgzip and indexed with tabix** (a `.tbi` must exist in the same directory), only -that region is read. Plain-text files are read whole and the region is ignored -with a warning. The tabix header line must begin with `#` so its column names -can be recovered. +that region is read. Plain-text files are read whole, with a warning, and the +region then selects the variants kept. Given in R, a `region` is a `GRanges`; +the path of a BED file also works, read as BED with a 0-based start. The tabix +header line must begin with `#` so its column names can be recovered. ```{r tabix-region} tabixDf <- sumstatsDf @@ -319,7 +326,7 @@ gwsRegion <- loadGwasSumStatsFromManifest( data.frame(study = "MyGWAS", sumStatsPath = gz), genome = "GRCh38", ldReference = ldReference, - region = "22:14560000-14565000" + which = GenomicRanges::GRanges("22:14560000-14565000") ) length(gwsRegion[[1]]) # only the two variants in the region ``` @@ -392,7 +399,7 @@ study; override the FORMAT tag names with `formatMapping` if they differ from ## Next steps The collections carry no QC yet. Run `summaryStatsQc()` before any downstream -analysis (it populates `qcInfo`; downstream pipelines require it): +analysis (it fills `qcOptions()`; downstream pipelines require it): ```{r qc, eval=FALSE} gws_qcd <- summaryStatsQc(gws, ldMismatchQcMethod = "slalom") diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd index d30dada2..8adb7071 100644 --- a/vignettes/ctwas-pipeline.Rmd +++ b/vignettes/ctwas-pipeline.Rmd @@ -51,7 +51,7 @@ Inputs: | `gwasSumStats` | one `GwasSumStats` whose elements are LD blocks | | `twasWeights` | per-gene `TwasWeights` / `QtlFineMappingResult` | | `twasZ` | optional pre-computed per-gene Z from `causalInferencePipeline()` | -| `fineMappingResult` | optional; enables the credible-set and PIP variant rescues | +| `fineMappingResult` | optional `QtlFineMappingResult` for the rescues | ```{r load-packages} library(pecotmr) @@ -61,7 +61,7 @@ library(pecotmr) `gwasSumStats` is **one** `GwasSumStats` object whose elements are LD blocks, keyed by its `blockId` column — not a list of per-block objects. -Build it with `loadGwasSumStatsFromManifest(..., ldBlocks = )` and +Build it with `loadGwasSumStatsFromManifest(..., which = )` and pass it through `summaryStatsQc()`. A single-block input is rejected: cTWAS estimates its group priors by EM @@ -89,8 +89,7 @@ gwasSumStats <- loadGwasSumStatsFromManifest( manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), genome = "hg38", ldReference = ldStem, - region = "chr22:10000000-19000000", - ldBlocks = blocks + which = blocks ) gwasByRegion <- summaryStatsQc( gwasSumStats, @@ -106,6 +105,7 @@ data(ctwasWeightsExample) res <- ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), + method = "susie", ctwasPriorParam = CtwasPriorParam( thin = 1, niterPrefit = 3, @@ -130,18 +130,18 @@ should carry into a real analysis: - `thin = 1` keeps every SNP (production runs thin to `0.1`). - `niterPrefit` / `niter` are cut to keep the vignette fast. - `min_nonSNP_PIP = 0` disables region screening. The bundled GWAS has no - genome-wide-significant signal, so the default (`0.5`) selects no region at - all and the result comes back empty. On real data, leave it alone. + genome-wide-significant signal, so the default (`0.5`) selects no region at + all and the result comes back empty. On real data, leave it alone. - `fallbackToPrefit = TRUE` recovers from the accurate-EM step returning - `NaN` on underpowered data by keeping the prefit estimates. + `NaN` on underpowered data by keeping the prefit estimates. ## Where genes come from `twasWeights` accepts two shapes: - a **flat** `TwasWeights` or `QtlFineMappingResult` (or a homogeneous list - of them) carrying `region` provenance. Each gene is assigned to its home - LD block by `start(region)`, matching cTWAS's own placement rule. + of them) carrying `region` provenance. Each gene is assigned to its home + LD block by `start(region)`, matching cTWAS's own placement rule. - a **pre-bucketed named list** keyed by `region_id`, used as-is. Blocks with no gene weights still contribute their SNP-level signal to the @@ -166,13 +166,17 @@ scales with them. Four arguments trim each gene before cTWAS sees it: `csMinCor` and `pipRescue` mark variants as must-keep, so they survive the `maxVariants` cap. Both need a `fineMappingResult`; without one they -are no-ops and the cap falls back to ordering by `abs(weight)`. +are no-ops and the cap falls back to ordering by `abs(weight)`. With one, +`fineMappingMethod` names which of its fine-mapping methods they read: a +weight's own method, such as an ensemble, names no fine-mapping fit. ```{r ctwas-filters, eval=FALSE} ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), + method = "susie", fineMappingResult = fmr, + fineMappingMethod = "susie", variantPruningParam = VariantPruningParam( weightCutoff = 1e-4, maxVariants = 1000, @@ -185,7 +189,8 @@ ctwasPipeline( ## Reading the result `ctwasPipeline()` returns a `CtwasResult`: one row per -`(gwasStudy, study, context, method)` run. +`(gwasStudy, study, context, method)` run and cTWAS region, the way a +`GwasFineMappingResult` holds a genome-wide fit as one row per LD block. ```{r ctwas-identity} methodNames(res) @@ -213,10 +218,11 @@ has no real signal) and `cs` is `NA` because the gene falls in no credible set. `susieAlpha()` returns the per-single-effect alpha matrix behind those -PIPs, and the EM group priors sit on each row's entry: +PIPs, and the run's EM group priors sit in the `groupPriors` column, the +same on every region of the run: ```{r ctwas-param} -param <- ctwasGroupPriors(res$entry[[1]]) +param <- res$groupPriors[[1]] param$group_prior param$group_prior_var param$converged @@ -224,7 +230,7 @@ param$converged By default the context-agnostic SNP background is dropped from the result, since it is the null the genes are being scored against rather than a -finding. Pass `keepSnps = TRUE` to retain it as an extra row +finding. Pass `keepSnps = TRUE` to retain it as extra rows, one per region (`study = context = "SNP"`), which makes the full cTWAS output reconstructable. @@ -237,7 +243,8 @@ re-enter the chain without recomputing what came before. ```{r ctwas-granular} inputs <- assembleCtwasInputs( gwasSumStats = gwasByRegion, - twasWeights = list(ctwasWeightsExample) + twasWeights = list(ctwasWeightsExample), + method = "susie" ) est <- estCtwasGroupPriors( inputs, @@ -270,8 +277,8 @@ carries the SNP rows. `asCtwasResult()` is the step that structures the payload and drops them. ```{r ctwas-as-result} -nrow(ctwasPosteriors(asCtwasResult(finemapped))) -nrow(ctwasPosteriors(asCtwasResult(finemapped, keepSnps = TRUE))) +length(ctwasPosteriors(asCtwasResult(finemapped))) +length(ctwasPosteriors(asCtwasResult(finemapped, keepSnps = TRUE))) ``` Each step's payload is also bundled, so you can enter anywhere: @@ -314,9 +321,9 @@ high-PIP gene actually straddles a boundary. ctwasPipeline( gwasSumStats = gwasByRegion, twasWeights = list(ctwasWeightsExample), - method = NULL, # NULL: "ensemble" if present, else every method + method = NULL, # NULL: the TwasWeights' "ensemble" weights maxNumSingleEffects = 5, - ncore = 1, + BPPARAM = BiocParallel::SerialParam(), keepSnps = FALSE, ctwasPriorParam = CtwasPriorParam( thin = 0.1, @@ -330,17 +337,18 @@ ctwasPipeline( ) ``` -When `method` is `NULL` and several weight methods are present without an -`"ensemble"`, each method runs as its own independent cTWAS run and -contributes its own row-set. +With `method = NULL` a run uses the TwasWeights' pre-combined `"ensemble"` +weights. Weights without an ensemble, and a `QtlFineMappingResult` used as +the weight source, leave the choice open, so the pipeline asks for `method`. +Each run reads one method; compare methods by running each in turn. ## Next steps - [TWAS weights](twas-weights.html) — training the weights cTWAS consumes. - [TWAS Z-scores and MR](twas-zscore.html) — the per-gene Z that - `twasZ` optionally supplies here. + `twasZ` optionally supplies here. - [QC for summary statistics](rss-qc.html) — `summaryStatsQc()`, which - `gwasSumStats` must have been through. + `gwasSumStats` must have been through. # Session info diff --git a/vignettes/fine-mapping.Rmd b/vignettes/fine-mapping.Rmd index 8c8b74ec..55b37ae4 100644 --- a/vignettes/fine-mapping.Rmd +++ b/vignettes/fine-mapping.Rmd @@ -56,7 +56,7 @@ data( qtlDatasetExample ``` -The `*_sumstats_example` objects ship with a non-empty `qcInfo` slot so +The `*_sumstats_example` objects ship with non-empty `qcOptions()` so they bypass the `summaryStatsQc()` gate. In a real analysis you'd construct the raw `QtlSumStats` / `GwasSumStats` from your data, then run `summaryStatsQc()` to populate that slot (see the @@ -141,8 +141,9 @@ fmrSs <- fineMappingPipeline(qtlSumStatsExample, methods = "susie") fmrSs ``` -The `QtlSumStats` collection carries an `ldReference` genotype panel; the -pipeline pulls the per-region LD from there automatically. +Each row of the `QtlSumStats` collection names its LD reference (here a +genotype panel); the pipeline pulls each region's LD from its row's reference +automatically. ## GWAS summary-statistics fine-mapping @@ -170,14 +171,17 @@ fineMappingPipeline( maxNumSingleEffects = 10L ), initializeWithSusieInf = TRUE, - naAction = "drop", # "drop" (default) or "impute" + phenotypeFilterParam = PhenotypeFilterParam(naAction = "drop"), verbose = 1 ) ``` -- `naAction` controls how phenotype NAs are handled by - `residualizedPhenotypes()`: `"drop"` removes samples with any NA across - the requested traits, `"impute"` mean-imputes each trait independently. +- `phenotypeFilterParam` is the run's phenotype QC. Its `naAction` says how + phenotype NAs are handled: `"drop"` (the default) removes samples with + any NA across the requested traits, `"impute"` mean-imputes each trait + independently. `outlierAction = "drop"` also removes samples flagged as + multivariate outliers. The QtlDataset accessors apply none of this; it + belongs to the run. - `initializeWithSusieInf = TRUE` runs SuSiE-inf first and uses its result to initialise the susie fit, which improves credible-set purity in regions with background polygenic signal. @@ -210,7 +214,9 @@ fineMappingPipeline( ``` The `jointSpecification` argument in `?fineMappingPipeline` gives the full -grammar, including the `study` axis for summary statistics. +grammar, including the `study` axis for summary statistics. On summary +statistics a joint fit uses one LD matrix, so the rows it combines must share +an LD reference; a group whose rows do not is an error. ## Reading the result @@ -252,14 +258,18 @@ length(pipOne) The underlying SuSiE fit is available with `susieFit()` and the cross-validation record with `cvResult()`, both keyed the same way. -Range-based subsetting works directly: +Range-based subsetting uses the standard verbs: subset the collection by its +rows' analysis windows, or narrow a ranged view directly: ```{r fm-range} window <- GenomicRanges::GRanges( "chr22", IRanges::IRanges(20000000, 21000000) ) -sum(lengths(subsetRegion(fmr, window))) +# the fits whose analysis window overlaps it +nrow(fmr[IRanges::overlapsAny(genomicRegion(fmr), window)]) +# the top loci inside it +length(IRanges::subsetByOverlaps(topLoci(fmr), window)) ``` ## Calling a fitter directly @@ -283,13 +293,13 @@ rather than the coefficients. Two are worth calling out: - `fsusieWrapper()` wraps `fitFsusie()` with the credible-band and - affected-region post-processing, and `fsusieGetCs()`, - `fsusieCredibleBand()` and `fsusieAffectedRegions()` read those out. - fSuSiE needs a *functional* phenotype — a curve per sample, not a scalar — - so it does not accept the same `Y` the other methods do. + affected-region post-processing, and `fsusieGetCs()`, + `fsusieCredibleBand()` and `fsusieAffectedRegions()` read those out. + fSuSiE needs a *functional* phenotype — a curve per sample, not a scalar — + so it does not accept the same `Y` the other methods do. - `fitSusieInfThenSusieRss()` chains the two: `susie_inf` first to estimate - the infinitesimal component, then SuSiE-RSS on the residual signal. That - is what `methods = "susieInf"` runs on summary statistics. + the infinitesimal component, then SuSiE-RSS on the residual signal. That + is what `methods = "susieInf"` runs on summary statistics. ## Next steps diff --git a/vignettes/finemapping-postprocessing.Rmd b/vignettes/finemapping-postprocessing.Rmd index be86bfd9..cb018e71 100644 --- a/vignettes/finemapping-postprocessing.Rmd +++ b/vignettes/finemapping-postprocessing.Rmd @@ -66,12 +66,11 @@ its standard error. They are deliberately *not* called `beta`/`se`: under those names, so sharing them would let the two views be joined into a silent mix of posterior and marginal effects. -Both are on the standardized genotype scale, because the `QtlDataset` -accessors centre and scale every genotype column to unit variance before -fitting — `residualizedGenotypes()` does it, governed by -`ResidualizationParam(scaleResiduals = FALSE)` per call or the dataset's own -`scaleResiduals` slot. The published `weight_standardized` records whichever -way it resolved. +Both are on the standardized genotype scale, because residualization centres +and scales every genotype column to unit variance before fitting — +`residualizedGenotypes()` does it, unless +`ResidualizationParam(scaleResiduals = FALSE)` says otherwise. The published +`weight_standardized` records whichever way it resolved. That is what makes a posterior effect comparable with a TWAS weight from any other method — they are all on the scale of the `X` the fitter was given, and on the same scale as the LD correlations and z-scores a TWAS Z is computed @@ -211,13 +210,14 @@ When the flat tables are not enough — you want the per-effect posterior, or to re-derive PIPs under a different assumption — the underlying fit is available. -`lbf()` returns the log Bayes factors, one row per variant and one +`lbf()` returns the log Bayes factors, one range per variant and one column per single effect: ```{r lbf} lbf <- lbf(qtlFineMappingLbfExample) -unit <- lbf[lbf$trait == lbf$trait[1] & lbf$context == lbf$context[1], ] -lbfMatrix <- as.matrix(unit[, grep("^lbf_L", names(unit))]) +unit <- lbf[lbf$trait == lbf$trait[1] & lbf$context == lbf$context[1]] +effects <- as.data.frame(S4Vectors::mcols(unit)) +lbfMatrix <- as.matrix(effects[, grep("^lbf_L", names(effects))]) dim(lbfMatrix) ``` @@ -258,10 +258,10 @@ The summaries above are not stored by the fitter — they are derived from the raw SuSiE fit by a short chain that `fineMappingPipeline()` runs for you: ``` -postprocessFinemappingFits() # per-method fits -> a post object - -> computeCsTables() # credible sets from alpha, with purity - -> buildTopLoci() # the flat one-row-per-variant table - -> formatFinemappingOutput() # assemble the result payload +postprocessFinemappingFits() # per-method fits -> a post object + -> computeCsTables() # credible sets from alpha, with purity + -> buildTopLoci() # the flat one-row-per-variant table + -> formatFinemappingOutput() # assemble the result payload ``` Call them directly when you have SuSiE fits from elsewhere and want @@ -274,45 +274,47 @@ Two smaller extractors sit at the row level and are what `credibleSetSummary()` is assembled from: - `extractCsInfo(fmRow, csNames, topLociTable, ldSource)` — per-credible-set - detail for one result row, including the between-variant correlations that - give `purity_min`, which is why it needs an `ldSource`. + detail for one result row, including the between-variant correlations that + give `purity_min`, which is why it needs an `ldSource`. - `extractTopPipInfo(fmRow, sumstats)` — the lead variant and its statistics, - joined against summary statistics. + joined against summary statistics. `susieResult()` unwraps a per-condition fit list into the single SuSiE object the other helpers expect. ## Writing results out -Two generics cover every published format. `exportToVcf()` serialises a -fine-mapping result — or summary statistics, or TWAS weights — to GWAS-VCF, -the interchange format most external tools read: one record per variant, one -sample per study or fitted model, and the statistics as FORMAT fields. +Two writers cover every published format. `writeGwasVcf()` serialises a +fine-mapping result, or summary statistics, or TWAS weights, to GWAS-VCF, the +interchange format most external tools read: one record per variant, one +sample per study or fitted model, and the statistics as FORMAT fields. It +writes through VariantAnnotation, which has to be installed. ```{r vcf, eval=FALSE} -exportToVcf( +writeGwasVcf( qtlFineMappingExample, - outputPath = "finemapping.vcf.gz", + "finemapping.vcf.gz", context = "context_1" ) ``` -It needs the `VariantAnnotation` package, which is a suggested dependency -rather than a hard one. +A GWAS study fine-mapped block by block is one fit, so its blocks are written +as one sample, with a `BID` field naming each variant's block; +`splitByBlock = TRUE` writes one file per block instead. -`exportToBed()` writes the published long-format tables instead, one row per +`writeBed()` writes the published long-format tables instead, one row per published observation, bgzipped and tabix-indexed when the path ends in `.gz`: ```{r bed, eval=FALSE} # the top-loci table: the posterior view joined to the marginal one -exportToBed(qtlFineMappingExample, "top_loci.bed.gz") +writeBed(qtlFineMappingExample, "top_loci.bed.gz") # every remaining column the view carries, after the published schema -exportToBed(qtlFineMappingExample, "top_loci_full.bed.gz", columns = "all") +writeBed(qtlFineMappingExample, "top_loci_full.bed.gz", columns = "all") # the fSuSiE table: one row per (context, credible set), carrying the fitted # curve at both resolutions -- the wavelet grid and its reinterpolation onto # the trait positions. `levels` keeps only one of the two. -exportToBed(fsusieFineMappingExample, "fsusie.bed.gz", schema = "fsusie") -exportToBed(fsusieFineMappingExample, "fsusie_grid.bed.gz", +writeBed(fsusieFineMappingExample, "fsusie.bed.gz", schema = "fsusie") +writeBed(fsusieFineMappingExample, "fsusie_grid.bed.gz", schema = "fsusie", levels = "wavelet") ``` @@ -329,7 +331,10 @@ file holds. ```{r read, eval=FALSE} res <- readFineMappingResult("top_loci.bed.gz") # only the variants of one region, from a tabix-indexed file -res <- readFineMappingResult("top_loci.bed.gz", region = "chr22:32e6-33e6") +res <- readFineMappingResult( + "top_loci.bed.gz", + which = GenomicRanges::GRanges("chr22:32000000-33000000") +) ``` It requires almost nothing: coordinate-encoding variant ids and a `PIP`. @@ -354,11 +359,11 @@ which is why both schemas publish it as `WGT`. ## Next steps - [Fine-mapping](fine-mapping.html) — producing the results this vignette - consumes. + consumes. - [Colocalization](coloc-pipeline.html) — the model that answers whether an - overlap reflects a shared causal variant. + overlap reflects a shared causal variant. - [TWAS weights](twas-weights.html) — reusing a fine-mapping fit as a weight - method. + method. # Session info diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd index 4e2d93c6..8b6b78d5 100644 --- a/vignettes/heritability.Rmd +++ b/vignettes/heritability.Rmd @@ -162,7 +162,7 @@ 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()`. +warning and compare `sampleSize()` 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 @@ -178,7 +178,7 @@ to cut it into, or one `LdMatrix` per block. One block has no jackknife. ```{r build-ref, eval=FALSE} panel <- readGenotypes(plink2Prefix = "/path/to/reference.chr22") -blocks <- read.delim("/path/to/ld_blocks.tsv") # chrom, start, end +blocks <- "/path/to/ld_blocks.bed" # a BED file, or a GRanges ldEigen <- buildLdEigen(panel, ldBlocks = blocks, genome = "hg38") ldScore <- buildLdScore(panel, ldBlocks = blocks, genome = "hg38") @@ -391,7 +391,7 @@ names(h2EstimateToSldscTrait(strat)) ## Next steps - [Molecular QTL enrichment](xqtl-enrichment.html) — the complementary - per-variant QTL/GWAS enrichment analysis. + per-variant QTL/GWAS enrichment analysis. - [QC for summary statistics](rss-qc.html) — preparing the GWAS side. # Session info diff --git a/vignettes/ld-infrastructure.Rmd b/vignettes/ld-infrastructure.Rmd index 5c2a20e7..a018cc3e 100644 --- a/vignettes/ld-infrastructure.Rmd +++ b/vignettes/ld-infrastructure.Rmd @@ -35,8 +35,10 @@ library(pecotmr) ## Two kinds of LD reference -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, +Every pipeline reads LD from one place: the LD reference of the collection +row it is working on. A collection can use one reference for every row or a +different one per row; `ldReference()` lists the distinct references, each +stored once. A reference is one of two things (or a mixture of either, below). - A **genotype panel**, read lazily from disk with `readGenotypes()`. LD is @@ -83,8 +85,8 @@ dim(R) 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. +paths relative to the meta file. `readGenotypes(ldMeta = , block = )` opens +the whole block whose row covers the window. ### An LdMatrix @@ -147,17 +149,21 @@ GenotypeMixture( ### Using a reference -Either kind goes in the same slot, and from there every step reads it the -same way: +Either kind is passed the same way, and from there every step reads it the +same way. One reference serves every row; a list gives each row (each study, +for `GwasSumStats`) its own: ```{r use, eval=FALSE} gwas <- GwasSumStats(..., ldReference = panel) # or ldReference = ld +gwas <- GwasSumStats(..., ldReference = list(panelA, panelB)) # per study ``` 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. +colocalization, say — each QTL row and the GWAS rows it is combined with must +use the same reference: 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. `colocboostPipeline()` is the exception: it reads each +side's LD from that side's own reference, so the two may differ. ## Computing LD from genotypes @@ -267,9 +273,9 @@ covered in the [QC vignette](rss-qc.html), where the motivation lives. - [QC for summary statistics](rss-qc.html) — matching statistics to a panel. - [Heritability](heritability.html) — `buildLdEigen()` / `buildLdScore()` - turn per-block LD into the statistics the h2 estimators consume. + turn per-block LD into the statistics the h2 estimators consume. - [Fine-mapping](fine-mapping.html) and [TWAS weights](twas-weights.html) — - the RSS methods that consume LD. + the RSS methods that consume LD. # Session info diff --git a/vignettes/mash-pipeline.Rmd b/vignettes/mash-pipeline.Rmd index b894f71a..6ddd4129 100644 --- a/vignettes/mash-pipeline.Rmd +++ b/vignettes/mash-pipeline.Rmd @@ -298,9 +298,9 @@ strong credible set should not carry a condition on its own. The contrast design itself is built from `makePairwiseContrastCol()`, which sets +1 and −1 for a pair of conditions in a zero vector, and -`fitMashContrast()`, which fits one feature's contrast. `mashPosteriorContrast()` -calls both across all features and pairs, so you only need them directly when -building a non-pairwise design. +`fitMashContrast()`, which fits one feature's contrast. +`mashPosteriorContrast()` calls both across all features and pairs, so you only +need them directly when building a non-pairwise design. ## Utilities @@ -320,9 +320,9 @@ The mash track ships a set of helpers for getting real data into shape: ## Next steps - [Building QtlSumStats objects](constructing-sumstats.html) — assembling - the multi-context input. + the multi-context input. - [TWAS weights](twas-weights.html) — where a mash prior is consumed, via - `MashPrior` and mr.mash. + `MashPrior` and mr.mash. # Session info diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index b6e12048..b6dde813 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -36,10 +36,10 @@ table to an LD reference panel. Two are frequently encountered in practice: The `summaryStatsQc()` function provides a convenient interface to performing many QC tasks to address these issues. It takes a `GwasSumStats` or `QtlSumStats` object (see the *Building QtlSumStats and GwasSumStats objects* -vignette), and returns a new collection of the same class with updated entries -and a populated `qcInfo` slot. Downstream pipelines require the `qcInfo` to be -populated, so QC is mandatory before fine-mapping, TWAS-weight learning, -colocalization, etc. +vignette), and returns a new collection of the same class with updated entries, +the options it ran with recorded in `qcOptions()`, and what it did to each row +in `qcInfo()`. Downstream pipelines require `qcOptions()` to be filled, so QC is +mandatory before fine-mapping, TWAS-weight learning, colocalization, etc. ```{r load-packages} library(pecotmr) @@ -75,15 +75,13 @@ gws_qcd <- summaryStatsQc( ``` `gws_qc` is a new `GwasSumStats` of the same class, with cleaned -entries and a populated `qcInfo` slot. The per-entry audit record is -accessible via `qcInfo()`: +entries. What QC did to each row is a table, `qcInfo()`, and the options it ran +with are `qcOptions()`: ```{r inspect-qcinfo, eval=FALSE} -qc <- qcInfo(gws_qcd) -str(qc$entryAudit[[1]]) # per-entry counts: variantsIn, mungeSumstatsDropped, -# keepVariantsDropped, skipRegionDropped, matchedAgainstLdReference, -# krigingOutliersDropped, ldMismatchOutliersDropped, ... -qc$options # the curated knobs you passed (frozen for provenance) +qcInfo(gws_qcd) # one row per tuple: variantsIn, matchedAgainstLdReference, +# krigingOutliersDropped, ldMismatchOutliersDropped, ..., variantsOut +qcOptions(gws_qcd)$options # the knobs you passed, kept for provenance ``` A non-zero `mafCutoff` requires every entry to carry a `MAF` mcol; non-zero @@ -193,10 +191,10 @@ It uses `susieR`'s kriging RSS diagnostic: ~`N(0, 1)` when the z-scores and LD panel agree. A large residual flags an allele-flip / LD-mismatch outlier; variants below a two-sided p-value threshold (default `5e-8`) are dropped. The number removed is recorded in - the `qcInfo` audit as `krigingOutliersDropped`. + the `qcInfo()` table 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 `ldReference` and +**RSS-only** check: it draws `R` from each row's LD reference and requires a `susieR` that exports `kriging_rss()` / `estimate_s_rss()` (otherwise it errors — which is why it is off by default). diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index fb30b254..29b38697 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -33,9 +33,9 @@ by `(study, context, trait, method)`, one element per tuple). | Input class | Methods supported | |---|---| -| `QtlDataset` | Univariate: LASSO, elastic net, mr.ash, MCP, SCAD, L0Learn, Bayesian alphabet, DPR. Multivariate: mr.mash, mvsusie | +| `QtlDataset` | Univariate: LASSO, elastic net, ridge, mr.ash, MCP, SCAD, L0Learn, Bayesian alphabet, DPR. Multivariate: mr.mash, mvsusie | | `MultiStudyQtlDataset` | Iterates over embedded studies; same methods as `QtlDataset` | -| `QtlSumStats` | RSS-only: LASSO, mr.ash, MCP, SCAD, L0Learn, DPR, PRS-CS, P+T. Multivariate: mr.mash, mvsusie | +| `QtlSumStats` | RSS-only: LASSO, elastic net, ridge, mr.ash, MCP, SCAD, L0Learn, DPR, PRS-CS, P+T. Multivariate: mr.mash, mvsusie | ```{r load-packages} library(pecotmr) @@ -174,8 +174,8 @@ twSs <- twasWeightsPipeline(qtlSumStatsExample, methods = "lasso") twSs ``` -The RSS path uses the `ldReference` genotype panel inside the -`QtlSumStats` collection to compute LD as needed. The same rule holds for +The RSS path computes LD as needed from each row's LD reference in the +`QtlSumStats` collection. 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`. @@ -196,7 +196,9 @@ twasWeightsPipeline( 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. +`?twasWeightsPipeline` gives the full grammar. On a `QtlSumStats` the +contexts are fitted against one LD matrix, so their rows must share an LD +reference. ```{r joint, eval=FALSE} # `qd`: a QtlDataset whose traits are measured in brain, liver and more. @@ -236,7 +238,7 @@ The families, and the `methods =` name each answers to: | Family | `methods =` | Function | |---|---|---| -| Penalized regression | `lasso`, `enet`, `mcp`, `scad`, `l0learn` | `lassoWeights()`, `enetWeights()`, … | +| Penalized regression | `lasso`, `enet`, `ridge`, `mcp`, `scad`, `l0learn` | `lassoWeights()`, `enetWeights()`, `ridgeWeights()`, … | | Bayesian alphabet | `bayesA` … `bayesR`, `bLasso` | `bayesAWeights()`, `bLassoWeights()`, … | | Dirichlet process regression | `dprVb`, `dprGibbs`, `dprAdaptiveGibbs` | `dprVbWeights()`, `dprGibbsWeights()`, … | | PRS-CS | `prsCs` (sumstats input only) | `prsCsWeights()` | @@ -249,17 +251,18 @@ of known tokens. Most families have an RSS counterpart taking summary statistics and an LD reference instead of `X`/`y` — `lassosumRssWeights()` for `lasso`, +`enetRssWeights()` and `ridgeRssWeights()` for `enet` and `ridge`, `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. +and so on; the Bayesian alphabet, `dprVb` and `dprAdaptiveGibbs` have none. +`enet` mixes the lasso and ridge penalties at `alpha = 0.5` on either input; +`methods = list(enet = list(alpha = 0.3))` sets another mixing. 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 @@ -323,11 +326,12 @@ twasWeightsPipeline( methods = "susie", contexts = "brain", traitId = "ENSG_example", - region = "chr22:25000000-26000000", cisWindow = 5e5, + # or, in place of traitId + cisWindow, a literal window: + # region = GenomicRanges::GRanges("chr22:25000000-26000000"), crossValidationParam = CrossValidationParam( folds = 5, - numThreads = 1, + BPPARAM = BiocParallel::SerialParam(), samplePartition = NULL, maxVariants = -1 ), @@ -345,14 +349,14 @@ twasWeightsPipeline( genotypeCovariates = NULL ), weightsDataType = NULL, - naAction = "drop" + phenotypeFilterParam = PhenotypeFilterParam(naAction = "drop") ) ``` - `EnsembleParam(enabled = TRUE)` adds an additional `ensembleWeights` row to the collection — a weighted combination of the individual methods' CV predictions, filtered by that bundle's `r2Threshold`. -- `naAction` is forwarded to `residualizedPhenotypes()` (see the +- `phenotypeFilterParam` is the run's phenotype QC (see the [fine-mapping vignette](fine-mapping.html#common-parameters) for semantics). @@ -393,17 +397,17 @@ do.call(weightsDataType, c(list(tw), key)) # tag carried through for reporting `weightStandardized()` is `TRUE` for anything the pipeline fitted: genotypes are centred and scaled to unit variance before every method runs, so all the -weights are on one scale. That scaling lives in the `QtlDataset` accessors, -not in the pipeline — `ResidualizationParam(scaleResiduals = FALSE)` opts out -per call, and the dataset's own `scaleResiduals` slot is the default — so the -recorded flag reports what was done rather than what you claimed. That is not bookkeeping. Every method here returns -coefficients on the scale of the `X` it was handed — exactly so for glmnet, -ncvreg, L0Learn, mr.ash, the Bayesian alphabet and `susieWeights()` — while -the DPR samplers are not even scale-equivariant, so rescaling `X` changes -their fit rather than just its units. Standardizing up front removes the -question, and lands on the scale the LD correlations and z-scores behind a -TWAS Z already use. `learnTwasWeights()` still takes `weightStandardized`, -because there you supply `X` yourself. +weights are on one scale. That scaling is part of residualization — +`ResidualizationParam(scaleResiduals = FALSE)` opts out, and it is on by +default — so the recorded flag reports what was done rather than what you +claimed. That is not bookkeeping. Every method here returns coefficients on the +scale of the `X` it was handed — exactly so for glmnet, ncvreg, L0Learn, +mr.ash, the Bayesian alphabet and `susieWeights()` — while the DPR samplers are +not even scale-equivariant, so rescaling `X` changes their fit rather than just +its units. Standardizing up front removes the question, and lands on the scale +the LD correlations and z-scores behind a TWAS Z already use. +`learnTwasWeights()` still takes `weightStandardized`, because there you supply +`X` yourself. `weights()` returns a named numeric vector for univariate methods and a matrix for multivariate ones. The remaining payloads are keyed the same way: @@ -415,16 +419,16 @@ is the form the downstream TWAS and MR steps consume. ## Publishing the weights -The same two generics that export fine-mapping results export weights. -`exportToVcf()` writes a GWAS-VCF-style file: one record per variant, one +The same two writers that write fine-mapping results write weights. +`writeGwasVcf()` writes a GWAS-VCF-style file: one record per variant, one sample per fitted model, the weight in the `WGT` FORMAT field, and each -model's identity in its own `##SAMPLE` header line. `exportToBed()` writes the +model's identity in its own `##SAMPLE` header line. `writeBed()` writes the same thing as a long table, one row per (variant, model). -```{r tw-export, eval=FALSE} -exportToVcf(tw, "weights.vcf.gz") -exportToVcf(tw, "lasso_weights.vcf.gz", method = "lasso") # one model -exportToBed(tw, "weights.bed.gz") +```{r tw-write, eval=FALSE} +writeGwasVcf(tw, "weights.vcf.gz") +writeGwasVcf(tw, "lasso_weights.vcf.gz", method = "lasso") # one model +writeBed(tw, "weights.bed.gz") ``` Both export the **full-data fit only**, and refuse an object that has none — @@ -435,8 +439,13 @@ 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", - method = "susie") +cv <- cvResult( + tw, + studyName = "s1", + context = "brain", + trait = "g1", + method = "susie" +) cv$performance # per-method metric matrix: corr, rsq, adj_rsq, pval, RMSE, MAE ``` @@ -451,7 +460,10 @@ and the credible sets. Selecting only such a method, as in ```{r tw-read, eval=FALSE} tw <- readTwasWeights("weights.bed.gz") -tw <- readTwasWeights("weights.bed.gz", region = "chr22:10e6-19e6") +tw <- readTwasWeights( + "weights.bed.gz", + which = GenomicRanges::GRanges("chr22:10000000-19000000") +) ``` A weight is all it requires, so a table converted from another tool reads with diff --git a/vignettes/twas-zscore.Rmd b/vignettes/twas-zscore.Rmd index 16827ea8..283f7be8 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -152,14 +152,13 @@ p-value than the normal approximation would. ## LD reference consistency -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 `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. +Both `twasWeights` and `fineMappingResult` record an LD reference per row. +Where a row has one, it must be the same LD reference as the `gwasSumStats` +rows it overlaps carry. The pipeline errors on mismatch. + +A QTL row with no LD reference (e.g. weights learned from individual-level +data without any RSS step) skips the panel check — useful for analyses that +mix individual-level QTL fits with sumstats GWAS. ## Common parameters diff --git a/vignettes/xqtl-enrichment.Rmd b/vignettes/xqtl-enrichment.Rmd index 2609fd6c..090879d3 100644 --- a/vignettes/xqtl-enrichment.Rmd +++ b/vignettes/xqtl-enrichment.Rmd @@ -82,9 +82,11 @@ par(op) ## Perform enrichment analysis `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 `ldReference`); +estimates, for every combination of GWAS fit `(gwasStudy, gwasMethod)` and QTL +unit `(qtlStudy, qtlContext, qtlMethod)`, how enriched the molecular QTLs are +among the GWAS causal variants. Each fine-mapping method is its own fit: a +GWAS study fine-mapped with two methods gives two PIP vectors, never one. The +GWAS collection must be RSS-derived (every row carries an LD reference); `gwasFineMappingExample` already does. ```{r enrichment} @@ -96,12 +98,11 @@ enrich_res <- qtlEnrichmentPipeline( enrich_res ``` -The result is a data frame with one row per -`(gwasStudy, qtlStudy, qtlContext)` combination, giving the enrichment estimate -(`enrichment`), its standard error (`enrichmentSe`), and the log-odds -(`enrichmentLogOdds`). These enrichment priors can then be supplied to a -colocalization analysis. This synthetic single-region example is for -illustration only; stable enrichment estimates require many fine-mapped +The result is a data frame with one row per such combination, giving the +enrichment estimate (`enrichment`), its standard error (`enrichmentSe`), and +the log-odds (`enrichmentLogOdds`). These enrichment priors can then be +supplied to a colocalization analysis. This synthetic single-region example is +for illustration only; stable enrichment estimates require many fine-mapped regions. ## Session information