diff --git a/DESCRIPTION b/DESCRIPTION index bf07385f..2aed4fa5 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -174,12 +174,13 @@ Collate: 'qtlEnrichmentPipeline.R' 'regularizedRegressionWrappers.R' 'relatednessQc.R' + 'twasWeights.R' + 'resultWriters.R' + 'resultReaders.R' 'sldscPostprocessingPipeline.R' 'sldscWrapper.R' - 'twasWeights.R' 'twasWeightsPipeline.R' 'twasWeightsRow.R' - 'vcfWriter.R' Depends: R (>= 4.5) LazyData: false diff --git a/NAMESPACE b/NAMESPACE index 47c4572d..57b01701 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -154,6 +154,7 @@ export(bayesCWeights) export(bayesLWeights) export(bayesNWeights) export(bayesRWeights) +export(blockId) export(blockMetadata) export(buildLdEigen) export(buildLdScore) @@ -210,6 +211,8 @@ export(ensembleWeights) export(estCtwasGroupPriors) export(estimateH2) export(estimateSparsity) +export(exportToBed) +export(exportToVcf) export(extractCsInfo) export(extractTopPipInfo) export(filterInvalidSummaryStat) @@ -233,8 +236,10 @@ export(frqData) export(fsusieAffectedRegions) export(fsusieCredibleBand) export(fsusieGetCs) +export(fsusieTraitEffects) export(fsusieWeights) export(fullFit) +export(genomicOrder) export(genomicRegion) export(genotypeCovariates) export(genotypes) @@ -343,10 +348,12 @@ export(qtlSumStatsFromZMatrix) export(raiss) export(readAfreq) export(readAnnotations) +export(readFineMappingResult) export(readGenotypes) export(readSldscAnnot) export(readSldscFrq) export(readSldscTrait) +export(readTwasWeights) export(refPanel) export(refVariantInfo) export(regionToDf) @@ -409,7 +416,6 @@ export(variantInfo) export(waldTestPval) export(weightStandardized) export(weightsDataType) -export(writeSumStatsVcf) export(xvarCutoff) export(z) exportClasses(AnnotationMatrix) @@ -486,6 +492,7 @@ exportMethods(as.data.frame) exportMethods(as.list) exportMethods(baselineAnnotations) exportMethods(bindROWS) +exportMethods(blockId) exportMethods(blockMetadata) exportMethods(coef) exportMethods(colnames) @@ -507,11 +514,14 @@ exportMethods(cvResult) exportMethods(eigenList) exportMethods(endoapply) exportMethods(estimateH2) +exportMethods(exportToBed) +exportMethods(exportToVcf) exportMethods(fineMappingPipeline) exportMethods(fineMappingResult) exportMethods(frqData) exportMethods(fsusieAffectedRegions) exportMethods(fsusieCredibleBand) +exportMethods(fsusieTraitEffects) exportMethods(fullFit) exportMethods(genomicRegion) exportMethods(genotypeCovariates) @@ -590,7 +600,6 @@ exportMethods(variantInfo) exportMethods(weightStandardized) exportMethods(weights) exportMethods(weightsDataType) -exportMethods(writeSumStatsVcf) exportMethods(xvarCutoff) exportMethods(z) importClassesFrom(GenomicRanges,GRanges) @@ -623,6 +632,7 @@ importFrom(GenomicRanges, start ) importFrom(IRanges, + CharacterList, DataFrameList, IRanges, findOverlaps @@ -632,7 +642,9 @@ importFrom(MultiAssayExperiment,longForm) importFrom(Rsamtools, TabixFile, asBcf, + bgzip, headerTabix, + indexTabix, scanTabix, seqnamesTabix ) diff --git a/R/AllClasses.R b/R/AllClasses.R index 80898645..153bd0f0 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -772,6 +772,7 @@ setMethod("methodNames", "FineMappingResultBase", function(x) { unique(as.character(x$method)) }) + #' @noRd setMethod( "adjustPips", @@ -1085,6 +1086,24 @@ setMethod("fsusieCredibleBand", "FineMappingResultBase", function(x) { .fmrAggregateView(x, perEntry = .fmrRowFsusieCredibleBand) }) +#' @rdname fsusieTraitEffects +#' @export +setMethod("fsusieTraitEffects", "FineMappingResultBase", 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) + parts <- compact(map( + seq_len(nrow(x)), + .fsusieEntryTraitEffects, + x = x, + meta = meta + )) + if (length(parts) == 0L) { + return(bind_cols(slice(meta, integer(0)), .emptyTraitEffects())) + } + .rbindAligned(parts) +}) + #' @rdname fsusieAffectedRegions #' @export setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x) { diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 1b2f7233..6721f949 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -1381,25 +1381,50 @@ setGeneric("weightsDataType", function(x, ...) { # AlleleQcResult accessor generics # QcResult accessor generics # ============================================================================= -# VCF/BCF writer generic +# Published-output generics (VCF/BCF and BED) # ============================================================================= -#' Write summary statistics or fine-mapping results to VCF/BCF +#' Export a result to VCF/BCF #' -#' Creates a VCF object from GWAS summary statistics or fine-mapping results and -#' writes it to disk via VariantAnnotation and Rsamtools. 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. +#' 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. #' -#' @param x Input data: a \code{GwasSumStats} object, a \code{FineMappingResult} -#' object, or a data.frame with columns \code{chrom}, \code{pos}, \code{ref}, -#' \code{alt}. +#' Which FORMAT fields are written depends on the input: +#' \describe{ +#' \item{\code{GwasSumStats}}{\code{ES} / \code{SS} / \code{AF} for one +#' study.} +#' \item{\code{FineMappingResult}}{the marginal fields (\code{ES}, +#' \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. +#' +#' @param x A \code{GwasSumStats}, \code{FineMappingResult} or +#' \code{TwasWeights} object, or a \code{list} of \code{FineMappingResult} +#' / \code{TwasWeights} objects to combine first. #' @param 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. -#' @param sampleName Name for the VCF sample column (default: trait name or -#' method name from the S4 object). +#' @param sampleName Name(s) for the VCF sample column(s). Default \code{NULL} +#' derives them from the object's identity tuple. #' @param studyName Character or \code{NULL}. Restrict the written records to #' this study; \code{NULL} includes all studies. #' @param context Character or \code{NULL}. Restrict the written records to this @@ -1413,14 +1438,109 @@ setGeneric("weightsDataType", function(x, ...) { #' @param splitByTrait Logical. If \code{TRUE}, write one VCF per trait. Default #' \code{FALSE}. #' @param ... Additional arguments passed to methods. -#' @return Invisible path to the written file. +#' @return Invisible path(s) to the written file(s). +#' @seealso \code{\link{exportToBed}} #' @examples #' data(gwasSumStatsS4Example) -#' writeSumStatsVcf( +#' exportToVcf( #' gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) #' @export -setGeneric("writeSumStatsVcf", function(x, outputPath, sampleName = NULL, ...) { - standardGeneric("writeSumStatsVcf") +setGeneric("exportToVcf", function(x, outputPath, sampleName = NULL, ...) { + standardGeneric("exportToVcf") +}) + +#' Export 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. +#' +#' A \code{TwasWeights} writes one table, a row per (variant, weight column). +#' A \code{FineMappingResult} offers two, selected with \code{schema}: +#' \describe{ +#' \item{\code{"topLoci"}}{(default) the posterior view joined to the +#' marginal one, a row per (variant, context).} +#' \item{\code{"fsusie"}}{the functional view, a row per (context, +#' credible set), carrying the fitted curve at both resolutions +#' \code{levels} selects.} +#' } +#' +#' Every table identifies the fit a row came from -- \code{study_ID}, +#' \code{gene_ID}, \code{event_ID} and (where it spans methods) +#' \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 +#' 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. +#' +#' @param x A \code{FineMappingResult} or \code{TwasWeights} object, or a +#' \code{list} of either, to combine first. +#' @param outputPath Output path. A \code{.gz} / \code{.bgz} extension selects +#' bgzip + tabix (via Rsamtools, so no htslib binary is needed); any other +#' extension writes a plain table. +#' @param schema \code{FineMappingResult} only: which published schema to +#' write, \code{"topLoci"} (default) or \code{"fsusie"}. +#' @param coverage Which credible-set coverage levels to publish, as +#' proportions (\code{c(0.95, 0.5)}). \code{NULL} (default) publishes every +#' level the input carries. Which levels exist is fixed at FIT time by +#' \code{\link{CredibleSetParam}} and the stored \code{cs_} columns are +#' read rather than recomputed, so this selects a subset and errors -- +#' naming what is available -- for a level the fit never computed. +#' @param levels \code{"fsusie"} schema only: which resolution(s) of the +#' fitted effect to write. fSuSiE carries the same effect twice -- +#' \code{"wavelet"}, the curve on the fit's own grid +#' (\code{\link{fsusieCredibleBand}}), and \code{"trait"}, that curve +#' reinterpolated onto the positions of the traits the fit ran over +#' (\code{\link{fsusieTraitEffects}}). They are complementary, so both are +#' written by default; naming one drops the other's columns, leaving a strict +#' subset of the full table. +#' @param signalCutoff PIP cutoff passed to \code{\link{topLoci}} +#' (\code{FineMappingResult}, \code{"topLoci"} schema only). Default 0.025. +#' @param minPurity Optional credible-set purity cutoff passed to +#' \code{\link{topLoci}} (\code{FineMappingResult}, \code{"topLoci"} schema +#' only). Default \code{NULL} for no purity filter. +#' @param columns Which of the SOURCE view's own variant-level columns to +#' append after the published schema. \code{NULL} (default) appends none; +#' \code{"all"} appends every column the view carries that the schema does +#' not already write; a character vector appends exactly those. The +#' published columns always lead, so adding to them never moves an existing +#' 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. +#' @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 +#' legacy top-loci BED's \code{block_id}, parsed from the source filename, +#' 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}} +#' @examples +#' data(qtlFineMappingExample) +#' exportToBed(qtlFineMappingExample, tempfile(fileext = ".bed")) +#' exportToBed( +#' qtlFineMappingExample, tempfile(fileext = ".bed"), +#' schema = "topLoci", columns = "all" +#' ) +#' data(twasWeightsExample) +#' exportToBed(twasWeightsExample, tempfile(fileext = ".bed")) +#' @export +setGeneric("exportToBed", function(x, outputPath, ...) { + standardGeneric("exportToBed") }) # ============================================================================= @@ -1460,19 +1580,64 @@ setGeneric("contexts", function(x) standardGeneric("contexts")) #' @export setGeneric("traitNames", function(x) standardGeneric("traitNames")) -#' @title Get Per-Row Genomic Regions -#' @description Return the genomic anchor of each row of a per-tuple collection -#' as a \code{GRanges} with one range per row -- the trait's own region for a -#' \code{TwasWeights}, or the fine-mapping window for a -#' \code{FineMappingResult}. This is location provenance (e.g. for cTWAS -#' LD-block placement). +#' @title Get Per-Row Analysis Windows +#' @description Return the genomic interval each row was analysed over, as a +#' \code{GRanges} with one range per row -- the trait's own region for a +#' \code{TwasWeights}, and for a \code{FineMappingResult} the window the fit +#' 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). +#' +#' 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 +#' \code{chr22:10000000-18000000} may contain variants spanning only +#' \code{chr22:10414272-16916492}. The window is stored because it cannot be +#' 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 +#' still produced by a fit over the original window. Use \code{range(x)} when +#' you want the current content instead. +#' +#' Collections built before the window was recorded fall back to the derived +#' span, so the accessor always returns a range. #' @param x The object. #' @param ... Reserved for future use. #' @return A \code{GRanges} with one range per row of \code{x}, or an empty -#' \code{GRanges} when the collection carries no region provenance. +#' \code{GRanges} when the collection has no rows. +#' @seealso \code{\link{traitPosition}} for the trait's own coordinates. #' @export setGeneric("genomicRegion", function(x, ...) standardGeneric("genomicRegion")) +#' @title Get The LD Block Identifier +#' @description Return the LD-block identifier of each row of a collection +#' that keys its rows by block --- a \code{GwasSumStats}, or a +#' \code{GwasFineMappingResult} fine-mapped over one. +#' +#' Per ROW, like \code{\link{genomicRegion}} and unlike +#' \code{\link{studyName}} / \code{\link{methodNames}}: a block id is +#' provenance for a particular fit, not an axis the collection is indexed +#' 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. +#' @param x The object. +#' @param ... Reserved for future use. +#' @return Character, one value per row of \code{x} (\code{NA} where the row +#' records none). +#' @seealso \code{\link{genomicRegion}} for the window that was analysed. +#' @examples +#' data(gwasFineMappingExample, qtlFineMappingExample) +#' blockId(gwasFineMappingExample) +#' # A QTL result has no block axis, so one NA per row rather than an error. +#' blockId(qtlFineMappingExample) +#' @export +setGeneric("blockId", function(x, ...) standardGeneric("blockId")) + #' @title Get Per-Row Trait Positions #' @description Return the molecular feature's OWN genomic coordinates (the gene #' / peak range; TSS = \code{start()}) for each row of a per-tuple collection, @@ -2287,9 +2452,12 @@ setGeneric("credibleSetSummary", function(x, ...) { #' #' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. #' @param ... Ignored. -#' @return A long \code{tibble}: \code{cs, chrom, pos, effect, lower, upper} -#' (the collection method additionally carries the entry identity columns). -#' @seealso \code{\link{fsusieAffectedRegions}} +#' @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). +#' @seealso \code{\link{fsusieTraitEffects}}, +#' \code{\link{fsusieAffectedRegions}} #' @examples #' data(fsusieFineMappingExample) #' fsusieCredibleBand(fsusieFineMappingExample) @@ -2298,6 +2466,34 @@ setGeneric("fsusieCredibleBand", function(x, ...) { standardGeneric("fsusieCredibleBand") }) +#' fSuSiE effect at each joint trait +#' +#' The fitted effect curve evaluated AT the traits the functional fit was run +#' over, one row per (credible set, trait). The curve itself lives on a wavelet +#' grid (\code{\link{fsusieCredibleBand}}); the traits sit at arbitrary +#' positions between grid points, so the effect is linearly interpolated with +#' constant extrapolation past the ends. +#' +#' This is the view that pairs a trait's NAME with its position: the names come +#' from the row's \code{jointTraits} column and the positions from the fit, +#' index-aligned because both describe the same joint group. Returns zero rows +#' when the functional fields are absent. +#' +#' @param x A \code{FineMappingRow} or \code{FineMappingResultBase}. +#' @param ... Ignored. +#' @return A long \code{tibble}: \code{cs, chrom, jointTrait, traitPos, +#' effect} (the collection method additionally carries the entry identity +#' columns). +#' @seealso \code{\link{fsusieCredibleBand}}, +#' \code{\link{fsusieAffectedRegions}} +#' @examples +#' data(fsusieFineMappingExample) +#' fsusieTraitEffects(fsusieFineMappingExample) +#' @export +setGeneric("fsusieTraitEffects", function(x, ...) { + standardGeneric("fsusieTraitEffects") +}) + #' fSuSiE affected genomic regions #' #' The sub-intervals of the functional grid where a credible set's band excludes diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index d072008c..1a2aefd9 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -59,6 +59,7 @@ setClass( c( .gfmrCheckEntryLength(object), .validateTraitPosColumn(object), + .validateRegionColumn(object), .gfmrCheckTupleUniqueness(object) ) } @@ -126,11 +127,30 @@ setClass( #' 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 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{ldSketch} cannot say which row came from which. +#' @param weightStandardized Optional per-row flag: whether the posterior +#' effect is on the STANDARDIZED genotype scale. The posterior effect IS the +#' prediction weight, so it carries the same scale question as a TWAS +#' weight. \code{\link{fineMappingPipeline}} always passes \code{TRUE}: +#' it standardizes genotypes before fitting, and the posterior mean is +#' reported on the scale of the \code{X} the fit was given. The argument +#' exists for a collection assembled by hand, where only the caller knows. #' @param ldSketch An optional genotype panel (see #' \code{\link{readGenotypes}}). #' @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. #' @examples #' tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), @@ -145,6 +165,10 @@ GwasFineMappingResult <- function( entry, blockId = NULL, traitPos = NULL, + region = NULL, + dataType = NULL, + dataSource = NULL, + weightStandardized = NULL, ldSketch = NULL ) { n <- length(studyName) @@ -160,7 +184,9 @@ GwasFineMappingResult <- function( cvResult = S4Vectors::SimpleList(map(entry, cvResult)) ) |> .appendBlockIdCol(blockId, n) |> - .appendTraitPosCol(traitPos, 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 diff --git a/R/QtlDataset.R b/R/QtlDataset.R index b2a5edc6..f3c7c1e5 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -1652,6 +1652,20 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { set_names(map(contexts, .qtlContextColData, x = x), contexts) }) +# Whether to scale residual columns to unit variance: the per-call override +# when the bundle sets one, else the dataset's own slot. +# +# 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, residualizationArgs) { + if (is.null(residualizationArgs)) { + return(scaleResiduals(x)) + } + residualizationArgs$scaleResiduals %||% scaleResiduals(x) +} + # Internal: residualize a numeric matrix Y (n x k) against a covariate # matrix C (n x p) via pivoted QR decomposition. Adds an intercept column # to C. When C is rank-deficient (e.g., union of all contexts' phenotype @@ -2021,7 +2035,7 @@ setMethod("phenotypeCovariates", "QtlDataset", function(x, contexts) { .qtlResidualizeQr( aligned$G, aligned$C, - scaleResiduals = scaleResiduals(x) + scaleResiduals = .qtlScaleResiduals(x, residualizationArgs) ) } @@ -2149,7 +2163,8 @@ setMethod( x = x, outlierAction = outlierAction, outlierPvalThreshold = outlierPvalThreshold, - outlierArgs = outlierArgs + outlierArgs = outlierArgs, + scaleResiduals = .qtlScaleResiduals(x, residualizationArgs) ) } @@ -2203,7 +2218,8 @@ setMethod( x, outlierAction, outlierPvalThreshold, - outlierArgs + outlierArgs, + scaleResiduals ) { out <- set_names( map( @@ -2214,7 +2230,8 @@ setMethod( x = x, outlierAction = outlierAction, outlierPvalThreshold = outlierPvalThreshold, - outlierArgs = outlierArgs + outlierArgs = outlierArgs, + scaleResiduals = scaleResiduals ), contexts ) @@ -2303,7 +2320,8 @@ setMethod("show", "QtlDataset", function(object) { x, outlierAction, outlierPvalThreshold, - outlierArgs = list() + outlierArgs = list(), + scaleResiduals = scaleResiduals(x) ) { .qtlResidualizeContextPheno( Yraw[[ctx]], @@ -2311,7 +2329,7 @@ setMethod("show", "QtlDataset", function(object) { ctx, outlierAction, outlierPvalThreshold, - scaleResiduals(x), + scaleResiduals, outlierArgs ) } @@ -2332,6 +2350,7 @@ setClass( genotypeCovariates = "CovariateSelection", residualizePhenotype = "logical_OR_NULL", residualizeGenotype = "logical_OR_NULL", + scaleResiduals = "logical_OR_NULL", covariateNaAction = "character_OR_NULL" ) ) @@ -2374,6 +2393,14 @@ setClass( #' read as \code{TRUE}. #' @param residualizeGenotype Logical. Residualize on the genotype #' 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. #' @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. @@ -2386,6 +2413,7 @@ ResidualizationParam <- function( genotypeCovariates = NULL, residualizePhenotype = NULL, residualizeGenotype = NULL, + scaleResiduals = NULL, covariateNaAction = NULL ) { # NULL means "unset", which is why the accessors no longer need a @@ -2398,6 +2426,7 @@ ResidualizationParam <- function( genotypeCovariates = genotypeCovariates, residualizePhenotype = residualizePhenotype, residualizeGenotype = residualizeGenotype, + scaleResiduals = scaleResiduals, covariateNaAction = covariateNaAction ) } diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 2ec638d2..f7dfe39a 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -71,6 +71,7 @@ setClass( c( .qfmrCheckEntryLength(object), .validateTraitPosColumn(object), + .validateRegionColumn(object), .qfmrCheckJointCols(object, jointCols), .qfmrCheckTupleUniqueness(object, jointCols) ) @@ -181,12 +182,31 @@ setClass( #' shape as \code{jointStudies}. #' @param jointTraits Optional character vector for cross-trait joints. Same #' shape as \code{jointStudies}. +#' @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{ldSketch} cannot say which row came from which. +#' @param weightStandardized Optional per-row flag: whether the posterior +#' effect is on the STANDARDIZED genotype scale. The posterior effect IS the +#' prediction weight, so it carries the same scale question as a TWAS +#' weight. \code{\link{fineMappingPipeline}} always passes \code{TRUE}: +#' it standardizes genotypes before fitting, and the posterior mean is +#' reported on the scale of the \code{X} the fit was given. The argument +#' exists for a collection assembled by hand, where only the caller knows. #' @param ldSketch An optional genotype panel (see \code{\link{readGenotypes}}) #' (the LD reference for RSS-derived fits), or \code{NULL} for #' individual-level fits. #' @param 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{QtlFineMappingResult} object. #' @examples #' tl <- data.frame(variant_id = paste0("chr1:", 100 * 1:3, ":A:G"), @@ -208,6 +228,10 @@ QtlFineMappingResult <- function( jointContexts = NULL, jointTraits = NULL, traitPos = NULL, + region = NULL, + dataType = NULL, + dataSource = NULL, + weightStandardized = NULL, ldSketch = NULL ) { .qfmrAssertArgs( @@ -234,6 +258,10 @@ QtlFineMappingResult <- function( jointContexts, jointTraits, traitPos, + region, + dataType, + dataSource, + weightStandardized, n ) obj <- new( @@ -286,6 +314,10 @@ QtlFineMappingResult <- function( jointContexts, jointTraits, traitPos, + region, + dataType, + dataSource, + weightStandardized, n ) { baseCols <- list( @@ -303,7 +335,17 @@ QtlFineMappingResult <- function( jointTraits, n ) - .appendTraitPosCol(withJoint, traitPos, n) + .appendFmProvenanceCols( + .appendRegionCol( + .appendTraitPosCol(withJoint, traitPos, n), + region, + n + ), + dataType, + dataSource, + weightStandardized, + n + ) } # Each joint-provenance column must be one value per row. diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index b0cb29bf..26cece45 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -230,6 +230,16 @@ methods::setValidity("RangedTupleList", function(object) { #' @export setMethod("nrow", "RangedTupleList", function(x) length(x)) +# One method on the shared base rather than one per flavour: every collection +# that keys rows by LD block stores the id in the same mcols column, and the +# ones that have no block axis want the same NA-padded answer. Serialized +# collections predating the column take that path too. +#' @rdname blockId +#' @export +setMethod("blockId", "RangedTupleList", function(x, ...) { + .fmrIdentityColumn(x, "blockId") +}) + #' @rdname RangedTupleList-methods #' @export setMethod("ncol", "RangedTupleList", function(x) { diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 97e2f0dc..35512d90 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -767,6 +767,12 @@ causalInferencePipeline <- function( } wr <- resolveWeights(ent) if (length(wr$variantIds) == 0L) { + warn(glue( + "causalInferencePipeline: no weights resolved for ", + "(study={studyName}, context={context}, trait={trait}, ", + "method={method}); skipping. The row carries variants but no ", + "usable weight, or the two are not the same length." + )) return(NULL) } wr @@ -971,13 +977,7 @@ causalInferencePipeline <- function( return(NULL) } cols <- .cipTlCols(tl) - if ( - length(cols$pip) == 0L || - length(cols$beta) == 0L || - length(cols$se) == 0L - ) { - return(NULL) - } + .cipRequireMrCols(cols, c("pip", "beta", "se"), "the Wald-ratio path") keep <- !is.na(tl[[cols$pip[[1L]]]]) & tl[[cols$pip[[1L]]]] > pipCutoff ivVars <- as.character(tl$variant_id)[keep] if (length(ivVars) == 0L) { @@ -1067,14 +1067,11 @@ causalInferencePipeline <- function( return(NULL) } cols <- .cipTlCols(tl) - if ( - length(cols$pip) == 0L || - length(cols$beta) == 0L || - length(cols$se) == 0L || - length(cols$cs) == 0L - ) { - return(NULL) - } + .cipRequireMrCols( + cols, + c("pip", "beta", "se", "cs"), + "the credible-set-aware path" + ) raw <- .cipCsAwareRaw(tl, cols) if (is.null(raw)) { return(NULL) @@ -1270,6 +1267,30 @@ causalInferencePipeline <- function( # Resolve the topLoci column aliases used across the CIP MR helpers. Returns the # first matching column name for each role (character(0) if absent); `cs` also # falls back to any column whose name starts with "cs" (e.g. cs_0.95). +# Abort naming the columns Mendelian randomization needs but the exposure does +# not have. +# +# These used to return NULL, so a result lacking `se` -- routine for a table +# converted from another tool, or read back from a published file whose source +# recorded only z -- produced "no (qtl, gwas) tuples produced a result" with +# nothing pointing at the cause. A column that is ABSENT is a structural +# property of the input and identical for every tuple, so it is worth stopping +# over; a column that is present but empty for one tuple stays a skip. +# @noRd +.cipRequireMrCols <- function(cols, need, label) { + absent <- need[map_int(cols[need], length) == 0L] + if (length(absent) == 0L) { + return(invisible(NULL)) + } + abort(glue( + "causalInferencePipeline: {label} needs ", + "{str_flatten(need, ', ')} on the exposure, and this result has no ", + "{str_flatten(absent, ', ')}. A result read from a published table ", + "carries beta/se only if the source recorded them, or if af and n ", + "let .zToBetaSe() derive them." + )) +} + .cipTlCols <- function(tl) { cn <- colnames(tl) exact <- intersect("cs", cn) @@ -1284,8 +1305,14 @@ causalInferencePipeline <- function( } list( pip = intersect(c("pip", "PIP"), cn), - beta = intersect(c("betahat", "beta", "bhat_x"), cn), - se = intersect(c("sebetahat", "se", "sbhat_x"), cn), + beta = intersect( + c("betahat", "beta", "bhat_x", "posterior_effect"), + cn + ), + se = intersect( + c("sebetahat", "se", "sbhat_x", "posterior_se"), + cn + ), cs = cs ) } diff --git a/R/colocPipeline.R b/R/colocPipeline.R index a44f1d3c..f3e30184 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -1151,14 +1151,15 @@ colocPipeline <- function( ) { fit <- susieFit(parts) if (is.null(fit)) { - msg <- glue("colocPipeline: {label} has no trimmedFit; skipping.") - warn(msg) - return(NULL) + abort(glue( + "colocPipeline: {label} has no retained fit, so it carries no ", + "LBF matrix and cannot be colocalized. Refit with ", + "`keepLbf = TRUE`." + )) } + # Filtering down to nothing below is a legitimate "no signal here" and + # stays a skip; it is only an ABSENT LBF that is an error. allRows <- .colocLbfMatrix(fit, label) - if (is.null(allRows)) { - return(NULL) - } allMass <- .colocEffectRetainedMass(fit, nrow(allRows)) keep <- .colocSelectLbfRows(allRows, fit, lbfFilterArgs) kept <- allRows[keep, , drop = FALSE] @@ -1181,39 +1182,31 @@ colocPipeline <- function( ) } -# Extract the (effects x variants) LBF matrix from a fit: susie lbf_variable, or -# a stacked fSuSiE lBF (direct or nested), or NULL (with a warning) when absent -# / empty. +# The (effects x variants) LBF matrix of a fit, or an ABORT. +# +# Delegates to .asLbfMatrix(), which knows every shape the LBF arrives in. +# These two used to keep separate shape lists and had drifted: coloc did not +# recognise a bare `fit$lBF`, which is what an fSuSiE fit carries, so fSuSiE +# colocalization skipped silently. +# +# A missing LBF is an ERROR, not a skip. coloc.bf_bf scores per-effect Bayes +# factors; without them there is nothing to approximate from -- a single-SNP +# ABF reconstructed from z/se is a different object on a different (prior- +# dependent) scale, and substituting one would quietly change the analysis. +# Warning per tuple and carrying on produced an empty result that looked like +# "no colocalization" rather than "the input cannot be colocalized", which is +# the wrong failure for a genome-wide run. # @noRd .colocLbfMatrix <- function(fit, label) { - lbfMatrix <- if (!is.null(fit$lbf_variable)) { - as.matrix(fit$lbf_variable) - } else if ( - !is.null(fit$fsusie_result) && - is.list(fit$fsusie_result$lBF) - ) { - # fSuSiE path: stack per-trait lBF lists into a single matrix. - lbfList <- fit$fsusie_result$lBF - exec(rbind, !!!lbfList) - } else if ( - is.list(fit) && - length(fit) >= 1L && - !is.null(fit[[1L]]$fsusie_result$lBF) - ) { - lbfList <- fit[[1L]]$fsusie_result$lBF - exec(rbind, !!!lbfList) - } else { - msg <- glue( - "colocPipeline: {label} trimmedFit has no lbf_variable / fsusie ", - "lBF; skipping." - ) - warn(msg) - return(NULL) - } + lbfMatrix <- .asLbfMatrix(fit) if (is.null(lbfMatrix) || nrow(lbfMatrix) == 0L) { - msg <- glue("colocPipeline: {label} LBF matrix is empty.") - warn(msg) - return(NULL) + abort(glue( + "colocPipeline: {label} carries no per-effect LBF matrix ", + "(no lbf_variable / fSuSiE lBF), so it cannot be colocalized. ", + "Refit with `keepLbf = TRUE`, or -- for a result read back from ", + "a published table -- export it from a fit built with ", + "`CredibleSetParam(perCsColumns = \"full\")`." + )) } lbfMatrix } diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 9cecffbd..592ad5c7 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -121,6 +121,16 @@ #' below its cutoffs is dropped before the LD matrix is built. The defaults #' filter nothing. See the Details section for how these relate to the #' individual-level cutoffs recorded on a \code{QtlDataset}. +#' @param residualizationArgs Covariate residualization settings for +#' 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 +#' \code{\link{fineMappingPipeline}} and +#' \code{\link{twasWeightsPipeline}}. \strong{Ignored} on +#' \code{QtlSumStats} input, which has nothing to residualize. #' @param alleleFlip Logical, default \code{TRUE}. When TRUE, harmonize variants #' across the individual X, sumstats, and LD by (chrom, pos) with ref/alt #' swaps recognized (flipping z / residualized dosage / LD to a shared @@ -297,7 +307,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region = NULL, cisWindow = NULL, samples = NULL, - pipCutoffToSkip = 0 + pipCutoffToSkip = 0, + residualizationArgs = ResidualizationParam() ) { contexts <- .cbResolveBundleContexts(qd, contexts) p <- list( @@ -306,7 +317,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region = region, cisWindow = cisWindow, samples = samples, - pipCutoffToSkip = pipCutoffToSkip + pipCutoffToSkip = pipCutoffToSkip, + residualizationArgs = residualizationArgs ) built <- compact(map(contexts, .cbBuildContextXY, p = p)) if (length(built) == 0L) { @@ -356,7 +368,13 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # NULL when the context should be skipped. # @noRd .cbBuildContextXY <- function(ctx, p) { - rawY <- .cbResidualizedY(p$qd, ctx, p$traitId, p$region) + rawY <- .cbResidualizedY( + p$qd, + ctx, + p$traitId, + p$region, + p$residualizationArgs + ) if (is.null(rawY) || ncol(rawY) == 0L) { return(NULL) } @@ -366,7 +384,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { p$traitId, p$region, p$cisWindow, - p$samples + p$samples, + p$residualizationArgs ) if (is.null(rawX) || ncol(rawX) == 0L) { return(NULL) @@ -401,13 +420,20 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized phenotypes for one context (message + NULL on failure). # @noRd -.cbResidualizedY <- function(qd, ctx, traitId, region) { +.cbResidualizedY <- function( + qd, + ctx, + traitId, + region, + residualizationArgs = ResidualizationParam() +) { try_fetch( residualizedPhenotypes( qd, contexts = ctx, traitId = traitId, - region = region + region = region, + residualizationArgs = residualizationArgs ), error = function(cnd) { msg <- glue( @@ -422,7 +448,15 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Residualized genotypes for one context (message + NULL on failure). # @noRd -.cbResidualizedX <- function(qd, ctx, traitId, region, cisWindow, samples) { +.cbResidualizedX <- function( + qd, + ctx, + traitId, + region, + cisWindow, + samples, + residualizationArgs = ResidualizationParam() +) { try_fetch( residualizedGenotypes( qd, @@ -430,7 +464,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { traitId = traitId, region = region, cisWindow = cisWindow, - samples = samples + samples = samples, + residualizationArgs = residualizationArgs ), error = function(cnd) { msg <- glue( @@ -933,7 +968,10 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { ) runJoint <- .cbCanRun(jointGwas, hasSs, "jointGwas", ssNeeded) runSeparate <- .cbCanRun( - separateGwas, hasGwasSs, "separateGwas", "GWAS summary statistics" + separateGwas, + hasGwasSs, + "separateGwas", + "GWAS summary statistics" ) compact(list( xqtl_coloc = if (runXqtl) { @@ -1534,8 +1572,12 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # each QTL study as a focal GWAS in its own right. gwasKeys <- setdiff(names(harmonized$pairs), qtlKeys) gwasRunBundles <- set_names( - map(gwasKeys, .cbGwasRunBundle, pairs = harmonized$pairs, - qtlKeys = qtlKeys), + map( + gwasKeys, + .cbGwasRunBundle, + pairs = harmonized$pairs, + qtlKeys = qtlKeys + ), gwasKeys ) .cbRunVariants( @@ -1607,7 +1649,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { panelFilterParam, signalScreenArgs, alleleFlip, - methodArgs + methodArgs, + residualizationArgs ) { screenSpec <- .screenResolve(signalScreenArgs) indBundle <- .cbIndividualBundle( @@ -1617,7 +1660,8 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { region = region, cisWindow = cisWindow, samples = samples, - pipCutoffToSkip = screenSpec + pipCutoffToSkip = screenSpec, + residualizationArgs = residualizationArgs ) .cbDriver( indBundle, @@ -1656,6 +1700,7 @@ setMethod( panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, + residualizationArgs = 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 @@ -1679,7 +1724,8 @@ setMethod( panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, alleleFlip = alleleFlip, - methodArgs = methodArgs + methodArgs = methodArgs, + residualizationArgs = residualizationArgs ) } ) @@ -1748,6 +1794,7 @@ setMethod( panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, + residualizationArgs = 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 @@ -1771,7 +1818,8 @@ setMethod( panelFilterParam = panelFilterParam, signalScreenArgs = signalScreenArgs, alleleFlip = alleleFlip, - methodArgs = methodArgs + methodArgs = methodArgs, + residualizationArgs = residualizationArgs ) } ) @@ -1794,7 +1842,8 @@ setMethod( panelFilterParam, signalScreenArgs, alleleFlip, - methodArgs + methodArgs, + residualizationArgs ) { screenSpec <- .screenResolve(signalScreenArgs) indBundle <- .cbMultiStudyIndBundle( @@ -1804,7 +1853,8 @@ setMethod( region = region, cisWindow = cisWindow, samples = samples, - screenSpec = screenSpec + screenSpec = screenSpec, + residualizationArgs = residualizationArgs ) cutoffs <- .panelCutoffs(panelFilterParam) ss <- .cbMultiStudySumstats( @@ -1844,7 +1894,8 @@ setMethod( region, cisWindow, samples, - screenSpec + screenSpec, + residualizationArgs = ResidualizationParam() ) { sub <- .cbIndividualBundle( qtlDatasets[[studyName]], @@ -1853,7 +1904,8 @@ setMethod( region = region, cisWindow = cisWindow, samples = samples, - pipCutoffToSkip = screenSpec + pipCutoffToSkip = screenSpec, + residualizationArgs = residualizationArgs ) if (is.null(sub)) { return(NULL) @@ -1886,7 +1938,8 @@ setMethod( region, cisWindow, samples, - screenSpec + screenSpec, + residualizationArgs = ResidualizationParam() ) { qtlDatasets <- qtlDatasets(qtlData) subs <- compact(map( @@ -1898,7 +1951,8 @@ setMethod( region = region, cisWindow = cisWindow, samples = samples, - screenSpec = screenSpec + screenSpec = screenSpec, + residualizationArgs = residualizationArgs )) if (length(subs) == 0L) { return(NULL) diff --git a/R/ctwasWrapper.R b/R/ctwasWrapper.R index e0c03ce4..7595b0a9 100644 --- a/R/ctwasWrapper.R +++ b/R/ctwasWrapper.R @@ -261,7 +261,10 @@ screenCtwasRegions <- function( #' @export CtwasGeneZOptions <- function(...) { .ctwasStepOptions( - list(...), .ctwasOwnedGeneZ(), "CtwasGeneZOptions", "ctwasGeneZ", + list(...), + .ctwasOwnedGeneZ(), + "CtwasGeneZOptions", + "ctwasGeneZ", "ctwas::compute_gene_z" ) } @@ -292,7 +295,8 @@ CtwasRegionDataOptions <- function(...) { thin = "CtwasPriorParam(thin =)", ncore = "the pipeline's own `numThreads`" ), - "CtwasRegionDataOptions", "ctwasRegionData", + "CtwasRegionDataOptions", + "ctwasRegionData", "ctwas::assemble_region_data" ) } @@ -321,7 +325,8 @@ CtwasEstParamOptions <- function(...) { group_prior_var_structure = "CtwasPriorParam(varStructure =)", ncore = "the pipeline's own `numThreads`" ), - "CtwasEstParamOptions", "ctwasEstParam", + "CtwasEstParamOptions", + "ctwasEstParam", c("ctwas::est_param", "ctwas::fit_EM") ) } @@ -343,7 +348,9 @@ CtwasScreenOptions <- function(...) { group_prior_var = "estimated by the EM step", ncore = "the pipeline's own `numThreads`" ), - "CtwasScreenOptions", "ctwasScreen", "ctwas::screen_regions" + "CtwasScreenOptions", + "ctwasScreen", + "ctwas::screen_regions" ) } @@ -365,7 +372,9 @@ CtwasExpandOptions <- function(...) { z_snp = "supplied from the data by the pipeline", ncore = "the pipeline's own `numThreads`" ), - "CtwasExpandOptions", "ctwasExpand", "ctwas::expand_region_data" + "CtwasExpandOptions", + "ctwasExpand", + "ctwas::expand_region_data" ) } @@ -392,7 +401,9 @@ CtwasFinemapOptions <- function(...) { snpinfo_loader_fun = "fixed by the pipeline's LD loaders", ncore = "the pipeline's own `numThreads`" ), - "CtwasFinemapOptions", "ctwasFinemap", "ctwas::finemap_regions" + "CtwasFinemapOptions", + "ctwasFinemap", + "ctwas::finemap_regions" ) } @@ -437,7 +448,8 @@ CtwasMergeOptions <- function(...) { snpinfo_loader_fun = "fixed by the pipeline's LD loaders", ncore = "the pipeline's own `numThreads`" ), - "CtwasMergeOptions", "ctwasMerge", + "CtwasMergeOptions", + "ctwasMerge", c( "ctwas::postprocess_region_merging", "ctwas::postprocess_region_merging_noLD", @@ -464,7 +476,8 @@ CtwasBoundaryGenesOptions <- function(...) { weights = "supplied from the data by the pipeline", ncore = "the pipeline's own `numThreads`" ), - "CtwasBoundaryGenesOptions", "ctwasBoundaryGenes", + "CtwasBoundaryGenesOptions", + "ctwasBoundaryGenes", "ctwas::get_boundary_genes" ) } @@ -523,7 +536,9 @@ CtwasOptions <- function( .assertMethodOptions(finemap, "CtwasFinemapOptions", "finemap") .assertMethodOptions(merge, "CtwasMergeOptions", "merge") .assertMethodOptions( - boundaryGenes, "CtwasBoundaryGenesOptions", "boundaryGenes" + boundaryGenes, + "CtwasBoundaryGenesOptions", + "boundaryGenes" ) .newMethodOptions( NULL, diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index 0a762fde..8b6ffcb5 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -321,8 +321,34 @@ #' which meant a misspelled option was dropped silently; the #' constructor checks the names against that function's live formals. #' } +#' @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. #' @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{\link{colocboostPipeline}}. An RSS fit needs nothing done: its +#' likelihood is written in standardized units already. +#' +#' It is what makes weights comparable across methods. Measured through +#' pecotmr's own entry points, every TWAS method returns coefficients on the +#' scale of the \code{X} it was given, and the DPR samplers are not even +#' scale-equivariant --- a uniform rescale of \code{X} changes their fit +#' rather than just its units. One input scale removes the question, and it +#' is the scale the LD correlations and z-scores behind a TWAS Z are already +#' on. +#' #' @return A \code{FineMappingResult} collection keyed by \code{(study, context, #' trait, method)}. The \code{ldSketch} slot is set automatically: \code{NULL} #' for individual-level (QtlDataset / all-individual-level @@ -828,6 +854,38 @@ setGeneric("fineMappingPipeline", function(data, ...) { .fmrRowParts(fineMappingResult, idx[[1L]]) } +# Record the three provenance columns every published export reads off a row. +# +# `dataType` is an outside fact (which assay the phenotype came from) and can +# only be supplied. The other two the pipeline KNOWS from the branch it took: +# a summary-statistics fit saw summary statistics, and the RSS likelihood is +# written in standardized units, so its posterior effects -- the prediction +# weights -- are on the standardized genotype scale by construction. An +# individual-level fit uses the X it was handed, so there the flag is the +# caller's to declare. +# +# Applied to the ASSEMBLED result rather than threaded into the builders: +# joint-engine rows are constructed on their own path and would otherwise +# reach `.rbindFineMappingResult` with a different column set. +# @noRd +.fmRecordProvenance <- function(x, dataType, dataSource, standardized) { + if (is.null(x)) { + return(x) + } + n <- nrow(x) + if (!is.null(dataType)) { + mcols(x)$dataType <- rep(as.character(dataType), length.out = n) + } + mcols(x)$dataSource <- rep(dataSource, length.out = n) + # 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 + # likelihood is written in standardized units to begin with. + mcols(x)$standardized <- rep(as.logical(standardized), length.out = n) + x +} + # Build a QtlFineMappingResult collection from per-tuple parallel vectors. # `jointStudies`, `jointContexts`, `jointTraits` are optional character # vectors (length matches `studies`) describing semicolon-joined joint @@ -844,6 +902,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { jointContexts = NULL, jointTraits = NULL, traitPos = NULL, + region = NULL, ldSketch = NULL, allowEmpty = FALSE ) { @@ -864,10 +923,55 @@ setGeneric("fineMappingPipeline", function(data, ...) { jointContexts = jointContexts, jointTraits = jointTraits, traitPos = traitPos, + region = region, ldSketch = ldSketch ) } +# The per-row ANALYSIS WINDOW for a set of (context, trait) rows: the explicit +# `region` when the caller named one, else each trait's own cis window +# (traitPos +/- cisWindow) -- which is the interval the cis path actually +# slices X over, so a per-gene fit records its window just as a region-mode +# fit does. NULL when nothing resolves, so the builder omits the column and +# genomicRegion() falls back to the derived span. +# The window ONE block was analysed over: the explicit range when the caller +# named one, else the cis window of the trait(s) the block covers -- the same +# interval .fmResidGenoBlock() slices X over when `rg` is NULL. Collapsed to a +# single range so a multi-trait block (a PC pseudo-trait over a context's +# traits) records the span it covered. +# @noRd +.fmBlockWindow <- function(rg, ctx, traits, cfg) { + if (!is.null(rg)) { + return(rg) + } + per <- try_fetch( + .anchorVector( + cfg$data, + rep(ctx, length(traits)), + traits, + "region", + cfg$cisWindow + ), + error = function(cnd) NULL + ) + if (is.null(per) || length(per) == 0L) { + return(NULL) + } + range(per)[1L] +} + +# @noRd +.fmRowWindows <- function(data, contexts, traits, region, cisWindow, n) { + explicit <- .analysisWindowForRows(region, n) + if (!is.null(explicit)) { + return(explicit) + } + try_fetch( + .anchorVector(data, contexts, traits, "region", cisWindow), + error = function(cnd) NULL + ) +} + # Build a GwasFineMappingResult collection from per-row vectors. `blockIds` is # optional provenance keying the external LD block manifest; row identity comes # from (study, method) plus the element's own range either way. @@ -877,6 +981,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { methods, entries, blockIds = NULL, + region = NULL, ldSketch = NULL, allowEmpty = FALSE ) { @@ -892,6 +997,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { method = methods, blockId = blockIds, entry = entries, + region = region, ldSketch = ldSketch ) } @@ -937,7 +1043,41 @@ setGeneric("fineMappingPipeline", function(data, ...) { # the identity of the row it ends up on agree by construction rather than by # two formatters happening to match. # @noRd -.fmGwasBlockId <- function(gr) { +# 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). +# 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 + ) + if ( + length(supplied) == 1L && + !is.na(supplied) && + !is.null(.fmBlockIdRange(supplied)) + ) { + return(supplied) + } + .fmGwasRangeKey(gr) +} + +# The entry's own range key. This is what the resume cache matches on -- it +# compares a cached row's DERIVED range key, so it must stay derived even when +# a block manifest supplies a wider boundary for the stored provenance. +# @noRd +.fmGwasRangeKey <- function(gr) { .rtlOneRangeKey(range(gr)) } @@ -955,6 +1095,63 @@ 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. NULL when no +# row's blockId carries coordinates, so the column is omitted and +# genomicRegion() falls back to the derived span. +# @noRd +.fmGwasRowWindows <- function(rows) { + if (length(rows) == 0L) { + return(NULL) + } + gs <- map(map_chr(rows, "blockId"), .fmBlockIdRange) + if (all(map_lgl(gs, is.null))) { + return(NULL) + } + # A row whose blockId holds no coordinates still needs a range; the + # chrUn sentinel marks it, matching .anchorVector()'s convention. + sentinel <- GenomicRanges::GRanges("chrUn", IRanges::IRanges(1L, 1L)) + exec(c, !!!map(gs, function(g) if (is.null(g)) sentinel else g)) +} + +# @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) +} + # Fit the still-to-run RSS tokens for one GWAS region and return one row-record # per fitted token. # @noRd @@ -965,7 +1162,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { toRun, glue("GWAS (study='{st}', region='{blockId}')"), .fmAfByVar(gr, zn$variantIds), - cfg + cfg, + region = .fmRssFitWindow(gr, zn$variantIds, blockId) ) map(names(ents), .fmGwasRowFor, st = st, blockId = blockId, ents = ents) } @@ -994,13 +1192,17 @@ setGeneric("fineMappingPipeline", function(data, ...) { ldSketch = cfg$ldSketch, cutoffs = .panelCutoffs(cfg$panelFilterParam) ) - blockId <- .fmGwasBlockId(gr) + # 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. + rangeKey <- .fmGwasRangeKey(gr) + blockId <- .fmGwasBlockId(cfg$data, i, gr) lookups <- map( tokens, .fmGwasLookup, fineMappingResult = cfg$fineMappingResult, st = st, - blockId = blockId + blockId = rangeKey ) cachedRows <- map( keep(lookups, .fmHasCached), @@ -1066,7 +1268,7 @@ setGeneric("fineMappingPipeline", function(data, ...) { # .fmFitRssBlock with the per-run knobs supplied from `cfg`; callers pass only # the block-specific arguments. The RSS analog of .fmFitXBlockP. # @noRd -.fmFitRssBlockP <- function(z, zn, toRun, label, af, cfg) { +.fmFitRssBlockP <- function(z, zn, toRun, label, af, cfg, region = NULL) { ldMat <- .ldFromSketch( cfg$ldSketch, zn$variantIds, @@ -1085,7 +1287,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { nVar = zn$nVar, credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, - susieRssParam = cfg$susieRssParam + susieRssParam = cfg$susieRssParam, + region = region ) } @@ -1109,7 +1312,8 @@ setGeneric("fineMappingPipeline", function(data, ...) { toRun, glue("(study='{st}', context='{ctx}', trait='{tr}')"), .fmAfByVar(entry, zn$variantIds), - cfg + cfg, + region = .fmRssFitWindow(entry, zn$variantIds) ) map(names(ents), .fmQtlRowFor, st = st, ctx = ctx, tr = tr, ents = ents) } @@ -1254,6 +1458,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ), 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( @@ -1267,6 +1478,7 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) } + # 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 @@ -2267,7 +2479,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ctx, label, afVec, - cfg + cfg, + region = NULL ) { .fmFitXBlock( X, @@ -2284,7 +2497,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { af = afVec, credibleSetParam = cfg$credibleSetParam, fitRetention = cfg$fitRetention, - seed = cfg$seed + seed = cfg$seed, + region = region ) } @@ -2332,7 +2546,17 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { region = rg, cisWindow = cfg$cisWindow ) - .fmFitXBlockP(X, y, toRun, cfg$initializeWithSusieInf, ctx, tid, afVec, cfg) + .fmFitXBlockP( + X, + y, + toRun, + cfg$initializeWithSusieInf, + ctx, + tid, + afVec, + cfg, + region = .fmBlockWindow(rg, ctx, tid, cfg) + ) } # All univariate row-records for one (context, trait): cache hits, then (when @@ -2409,7 +2633,17 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { ) # The PC path never chains susieInf: a PC is not a trait whose fit the # susieInf stage is defined for. - .fmFitXBlockP(Xb, pcY[common], "susie", FALSE, ctx, pcName, afVec, cfg) + .fmFitXBlockP( + Xb, + pcY[common], + "susie", + FALSE, + ctx, + pcName, + afVec, + cfg, + region = .fmBlockWindow(rg, ctx, traits, cfg) + ) } # Row-records for one PC pseudo-trait: a cache hit, else per-window fits merged @@ -2817,7 +3051,13 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { # trait-anchored cis span) combined with the joint result. Errors only when # neither path produced anything. # @noRd -.fmQdsAssemble <- function(data, rows, jointResult) { +.fmQdsAssemble <- function( + data, + rows, + jointResult, + region = NULL, + cisWindow = NULL +) { rowContext <- map_chr(rows, "context") rowTrait <- map_chr(rows, "trait") perTupleResult <- if (length(rows) > 0L) { @@ -2831,6 +3071,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { .anchorVector(data, rowContext, rowTrait, "traitPos"), error = function(cnd) NULL ), + region = .fmRowWindows( + data, + rowContext, + rowTrait, + region, + cisWindow, + length(rows) + ), ldSketch = NULL ) } else { @@ -2895,6 +3143,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { .fmQdsAssemble( data, rows, + region = region, + cisWindow = commonCfg$cisWindow, .fmQdsAutoJoint( jointCfg, mvTokens = split$mvTokens, @@ -2938,7 +3188,8 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { dataDrivenPriorWeightsCutoff = 1e-10, naAction = c("drop", "impute"), verbose = 1, - fitRetention = c("slim", "full") + fitRetention = c("slim", "full"), + dataType = NULL ) { fitRetention <- arg_match(fitRetention) naAction <- arg_match(naAction, c("drop", "impute")) @@ -2991,9 +3242,14 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { jointCfg ) if (rt$done) { - return(rt$result) + return(.fmRecordProvenance( + rt$result, + dataType, + "individual", + .qtlScaleResiduals(data, residualizationArgs) + )) } - .fmQdsRunAndAssemble( + out <- .fmQdsRunAndAssemble( data, commonCfg, jointCfg, @@ -3008,6 +3264,12 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { naAction = naAction, usePCA = usePCA ) + .fmRecordProvenance( + out, + dataType, + "individual", + .qtlScaleResiduals(data, residualizationArgs) + ) } #' @rdname fineMappingPipeline @@ -3024,6 +3286,37 @@ 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. A sumstats-only collection is in standardized units regardless. +# @noRd +.fmMsScaleResiduals <- function(data, residualizationArgs) { + if (!is.null(residualizationArgs$scaleResiduals)) { + return(residualizationArgs$scaleResiduals) + } + if (identical(.fmMsDataSource(data), "sumstat")) { + return(TRUE) + } + perStudy <- unique(map_lgl(qtlDatasets(data), scaleResiduals)) + if (length(perStudy) == 1L) perStudy else NA +} + +# The `data_source` a MultiStudyQtlDataset run can state for its JOINT rows. A +# joint fit spans the studies the specification selected, so when the +# collection holds both individual-level and summary-statistics studies there +# is no single answer and the column is left NA (and so dropped on export) +# rather than guessed. +# @noRd +.fmMsDataSource <- function(data) { + hasIndividual <- length(qtlDatasets(data)) > 0L + hasSumstats <- length(sumStats(data)) > 0L + if (hasIndividual && hasSumstats) { + return(NA_character_) + } + if (hasSumstats) "sumstat" else "individual" +} + # Per-embedded-study fine-mapping worker for .multiStudyPipelineDriver: recurse # fineMappingPipeline on one QtlDataset with the individual-capable methods. # `cfg` bundles the parent call's forwarded arguments. @@ -3063,7 +3356,8 @@ setMethod( nPCs = cfg$nPCs, fitRetention = cfg$fitRetention, mrmashPrior = cfg$mrmashPrior, - dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + dataType = cfg$dataType ) } @@ -3094,7 +3388,8 @@ setMethod( susieRssParam = cfg$susieRssParam, fitRetention = cfg$fitRetention, mrmashPrior = cfg$mrmashPrior, - dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff + dataDrivenPriorWeightsCutoff = cfg$dataDrivenPriorWeightsCutoff, + dataType = cfg$dataType ) } @@ -3261,9 +3556,12 @@ setMethod( seed = NULL, naAction = c("drop", "impute"), verbose = 1, - fitRetention = c("slim", "full") + fitRetention = c("slim", "full"), + dataType = NULL ) { fitRetention <- arg_match(fitRetention) + # The joint rows are recorded here; each per-study recursion records its + # own, so both sides of the driver's rbind carry the same columns. inputs <- .fmMsResolveInputs(naAction, region, cisWindow, jointRegions) naAction <- inputs$naAction # One record of the settings the joint phase and the shared dispatcher @@ -3286,13 +3584,21 @@ setMethod( credibleSetParam$maxNumSingleEffectsGreedy, jointCfg ) + jointResult <- .fmRecordProvenance( + rt$result, + dataType, + .fmMsDataSource(data), + # A sumstats-only collection is in standardized units whatever the + # hatch says; otherwise the hatch decides. + .fmMsScaleResiduals(data, residualizationArgs) + ) if (rt$done) { - return(rt$result) + return(jointResult) } methods <- rt$methods .multiStudyPipelineDriver( data, - rt$result, + jointResult, .fmPerStudy, .fmSumStats, list( @@ -3318,7 +3624,8 @@ setMethod( nPCs = nPCs, fitRetention = fitRetention, mrmashPrior = mrmashPrior, - dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff + dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, + dataType = dataType ), .rbindFineMappingResult, QtlFineMappingResult, @@ -3846,6 +4153,14 @@ NULL .anchorVector(data, rowContext, rowTrait, "traitPos"), error = function(cnd) NULL ), + region = .fmRowWindows( + data, + rowContext, + rowTrait, + NULL, + NULL, + length(rows) + ), ldSketch = ldSketch ) } else { @@ -3929,7 +4244,8 @@ NULL verbose, fitRetention, susieRssParam, - panelFilterParam + panelFilterParam, + dataType = NULL ) { .fmAssertQcd(data) cfgs <- .fmQssConfigs( @@ -3954,9 +4270,9 @@ NULL jointCfg ) if (rt$done) { - return(rt$result) + return(.fmRecordProvenance(rt$result, dataType, "sumstat", TRUE)) } - .fmQssAfterJoint( + out <- .fmQssAfterJoint( data, rt = rt, commonCfg = commonCfg, @@ -3966,6 +4282,7 @@ NULL initializeWithSusieInf = initializeWithSusieInf, susieRssParam = susieRssParam ) + .fmRecordProvenance(out, dataType, "sumstat", TRUE) } # Everything after the joint phase has had its say: select the rows the @@ -4068,7 +4385,8 @@ setMethod( susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam() + residualizationArgs = ResidualizationParam(), + dataType = NULL ) { fitRetention <- arg_match(fitRetention) .cvRefuseOnSumstats( @@ -4090,7 +4408,8 @@ setMethod( verbose = verbose, fitRetention = fitRetention, susieRssParam = susieRssParam, - panelFilterParam = panelFilterParam + panelFilterParam = panelFilterParam, + dataType = dataType ) } ) @@ -4149,7 +4468,8 @@ setMethod( verbose, fitRetention, susieRssParam, - panelFilterParam + panelFilterParam, + dataType = NULL ) { .fmAssertQcd(data) norm <- .fmNormalizeMethods( @@ -4173,7 +4493,7 @@ setMethod( verbose = verbose, panelFilterParam = panelFilterParam ) - .fmGwasRunEntries( + out <- .fmGwasRunEntries( data, studyCol = studyCol, tokens = tokens, @@ -4183,6 +4503,7 @@ setMethod( methodArgs = methodArgs, susieRssParam = susieRssParam ) + .fmRecordProvenance(out, dataType, "sumstat", TRUE) } # Fine-map every row of the GWAS collection and assemble the result. @@ -4219,6 +4540,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), ldSketch = ldSketch, allowEmpty = (nSkipped > 0L || nrow(data) == 0L) ) @@ -4240,7 +4565,8 @@ setMethod( susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam() + residualizationArgs = ResidualizationParam(), + dataType = NULL ) { fitRetention <- arg_match(fitRetention) .cvRefuseOnSumstats( @@ -4257,7 +4583,8 @@ setMethod( verbose = verbose, fitRetention = fitRetention, susieRssParam = susieRssParam, - panelFilterParam = panelFilterParam + panelFilterParam = panelFilterParam, + dataType = dataType ) } ) diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index bc2abdd9..e70c541b 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -204,7 +204,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { !is.null(fit$fitted_func) && !is.null(fit$outing_grid) && (!is.null(fit$cred_band) || - (!is.null(fit$fitted_wc2) && !is.null(fit$alpha))) + (!is.null(fit$fitted_wc2) && !is.null(fit$alpha))) } # Chromosome of the fit's variants (matches topLoci's `chrom`, no "chr"). @@ -224,10 +224,120 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { pos = numeric(), effect = numeric(), lower = numeric(), - upper = numeric() + upper = numeric(), + halfwidth = numeric() ) } +# ---- fsusieTraitEffects helpers ------------------------------------- + +# The fit's effect curve lives on a wavelet GRID; the traits it was fit over sit +# at arbitrary positions between grid points. Evaluating the curve AT each trait +# is linear interpolation with constant extrapolation past the ends (rule = 2), +# which is what a per-trait effect means for a functional fit. +# @noRd +.fsusieTraitEffectRow <- function(l, fit, grid, pos, traitNames, chrom) { + eff <- fit$fitted_func[[l]] + if (is.null(eff)) { + return(NULL) + } + tibble( + cs = str_c("fsusie_", l), + chrom = chrom, + jointTrait = traitNames, + traitPos = pos, + effect = stats::approx( + grid, + as.numeric(eff), + xout = pos, + rule = 2, + ties = "ordered" + )$y + ) +} + +# @noRd +.emptyTraitEffects <- function() { + tibble( + cs = character(), + chrom = character(), + jointTrait = character(), + traitPos = numeric(), + effect = numeric() + ) +} + +# One entry's per-trait effects. `traitNames` is index-aligned with the fit's +# `trait_positions` -- both come from the same joint group, which is why the +# names can be carried in the row's `jointTraits` column while only the +# positions ride on the fit. +# @noRd +.fsusieTraitEffectsFit <- function(fit, traitNames) { + if (!.isFsusieFit(fit) || is.null(fit$trait_positions)) { + return(.emptyTraitEffects()) + } + grid <- as.numeric(fit$outing_grid) + pos <- as.numeric(fit$trait_positions) + if (length(traitNames) != length(pos)) { + msg <- glue( + "fsusieTraitEffects: the fit has {length(pos)} trait position(s) ", + "but {length(traitNames)} trait name(s). They index the same ", + "joint group, so a mismatch means the stored fit and ", + "`jointTraits` disagree." + ) + abort(msg) + } + chrom <- .fsusieChrom(fit) + parts <- compact(map( + seq_along(fit$fitted_func), + .fsusieTraitEffectRow, + fit = fit, + grid = grid, + pos = pos, + traitNames = traitNames, + chrom = chrom + )) + if (length(parts) == 0L) { + return(.emptyTraitEffects()) + } + bind_rows(parts) +} + +# The joint members of row `i`, index-aligned with the fit's trait_positions. +# A fit over a single trait has no `jointTraits` entry, so fall back to the +# row's own trait id. +# @noRd +.fmrJointTraitNames <- function(x, i) { + cols <- .tupleColumnNames(x) + jt <- if (is_in("jointTraits", cols)) { + as.character(x$jointTraits[[i]]) + } else { + NA_character_ + } + if (length(jt) != 1L || is.na(jt) || !nzchar(jt)) { + return( + if (is_in("trait", cols)) { + as.character(x$trait[[i]]) + } else { + character(0) + } + ) + } + str_split_1(jt, fixed(";")) +} + +# @noRd +.fsusieEntryTraitEffects <- function(i, x, meta) { + v <- .fsusieTraitEffectsFit( + susieFit(.fmrRowParts(x, i)), + .fmrJointTraitNames(x, i) + ) + if (nrow(v) == 0L) { + return(NULL) + } + bind_cols(slice(meta, rep(i, nrow(v))), v) +} + # @noRd .fsusieCredibleBandFit <- function(fit) { if (!.isFsusieFit(fit)) { @@ -328,7 +438,9 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # ---- map/apply helpers (lambda-free callbacks) --------------------------- # One credible band's variant-level data.frame (effect + lower/upper), or NULL -# when band `l` has no fitted band/effect. +# when band `l` has no fitted band/effect. `halfwidth` is the band's half-width +# at each grid point -- the symmetric +/- quantity publication tables carry, +# which every consumer otherwise re-derives as (upper - lower) / 2. # @noRd .fsusieBandRow <- function(l, fit, chrom, grid) { band <- fit$cred_band[[l]] @@ -336,13 +448,16 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (is.null(band) || is.null(eff)) { return(NULL) } + lower <- as.numeric(band[2, ]) + upper <- as.numeric(band[1, ]) tibble( cs = str_c("fsusie_", l), chrom = chrom, pos = grid, effect = as.numeric(eff), - lower = as.numeric(band[2, ]), - upper = as.numeric(band[1, ]) + lower = lower, + upper = upper, + halfwidth = (upper - lower) / 2 ) } @@ -636,8 +751,8 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { cs_log_bf = .csEffectLogBf(ctx$fit, Lidx), # cs_pip: total posterior inclusion mass captured by the CS. cs_pip = suppressWarnings(sum(as.numeric(m$pip), na.rm = TRUE)), - # cs_mean_effect: mean posterior conditional effect over the CS (NA when - # the entry has no conditional_effect column, e.g. univariate susie). + # cs_mean_effect: mean effect over the CS members CONDITIONAL on the + # variant being causal, i.e. the posterior mean over the PIP. cs_mean_effect = .csMeanEffect(m), lead_variant = as.character(m$variant_id[lead]), lead_pip = as.numeric(m$pip[lead]) @@ -683,21 +798,41 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (length(v) == 0L) NA_real_ else max(v) } -# cs_mean_effect: mean conditional effect over the CS (NA when absent). +# cs_mean_effect: the mean over the CS members of the effect conditional on +# the variant being causal. +# +# Derived from `posterior_mean / pip` rather than read from a stored +# `conditional_effect` column. That column was `coef[, condition] / pip`, +# which IS this quotient now that `.btlPosterior()` puts the posterior mean on +# the same scale `coef()` uses -- verified exactly against a real mvsusie fit. +# Before that change the two differed by the per-variant standardization +# factor, so the column was carrying information the table lacked and could +# not be dropped. +# +# A knock-on improvement: this is now populated for univariate susie too, +# where the stored column only ever existed for multi-condition fits. # @noRd .csMeanEffect <- function(m) { - if (!is_in("conditional_effect", names(m))) { + effect <- suppressWarnings(as.numeric(.csColumn(m, "posterior_mean"))) + pip <- suppressWarnings(as.numeric(.csColumn(m, "pip"))) + if (length(effect) == 0L || length(pip) != length(effect)) { return(NA_real_) } # suppressWarnings covers only the coercion; the empty case is handled - # explicitly so it returns NA_real_ rather than NaN. + # explicitly so it returns NA_real_ rather than NaN. A zero PIP has no + # conditional effect to speak of and drops out with the non-finites. v <- keep( - suppressWarnings(as.numeric(m$conditional_effect)), + if_else(!is.na(pip) & pip > 0, effect / pip, NA_real_), is.finite ) if (length(v) == 0L) NA_real_ else mean(v) } +# @noRd +.csColumn <- function(m, nm) { + if (is_in(nm, names(m))) m[[nm]] else numeric(0) +} + # Apply the pip `signalCutoff` + optional purity filter, then project to the # posterior view. An empty topLoci passes through unchanged. @@ -1270,21 +1405,27 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # given type when the column is absent. Lets accessor projectors tolerate # skeletal entries that lack optional columns. # @noRd -.tlCol <- function(tl, name, type = c("character", "integer", "numeric")) { +.tlCol <- function( + tl, + name, + type = c("character", "integer", "numeric", "logical") +) { type <- arg_match(type) if (is_in(name, colnames(tl))) { return(switch( type, character = as.character(tl[[name]]), integer = as.integer(tl[[name]]), - numeric = as.numeric(tl[[name]]) + numeric = as.numeric(tl[[name]]), + logical = as.logical(tl[[name]]) )) } switch( type, character = rep(NA_character_, nrow(tl)), integer = rep(NA_integer_, nrow(tl)), - numeric = rep(NA_real_, nrow(tl)) + numeric = rep(NA_real_, nrow(tl)), + logical = rep(NA, nrow(tl)) ) } @@ -1307,8 +1448,11 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { A2 = .tlCol(tl, "A2", "character"), N = .tlCol(tl, "N", "numeric"), af = .tlCol(tl, "af", "numeric"), - beta = .tlCol(tl, "posterior_mean", "numeric"), - se = .tlCol(tl, "posterior_sd", "numeric"), + # NOT `beta`/`se`: marginalEffects() publishes the MARGINAL estimate + # under those names, so using them here for the posterior mean made + # the two views silently joinable into a mix of the two quantities. + posterior_effect = .tlCol(tl, "posterior_mean", "numeric"), + posterior_se = .tlCol(tl, "posterior_sd", "numeric"), pip = .tlCol(tl, "pip", "numeric"), logBF = .tlCol(tl, "logBF", "numeric") ) @@ -1332,8 +1476,8 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { A2 = character(0), N = numeric(0), af = numeric(0), - beta = numeric(0), - se = numeric(0), + posterior_effect = numeric(0), + posterior_se = numeric(0), pip = numeric(0), logBF = numeric(0) ) @@ -1342,9 +1486,11 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # Optional pass-through columns for the posterior view, in canonical order: the # dynamic CS columns (cs_ membership / cs__purity), the per-CS variant- # level fullFit columns (within_cs_pip[_] / cs_logbf_ / -# cs_effect[_var]_), the per-condition posterior quantities -# (conditional_effect, lfsr), and pipeline-added annotations -- whichever are -# present. +# cs_effect[_var]_), the per-condition `lfsr`, and pipeline-added +# annotations -- whichever are present. +# +# `conditional_effect` was one of these and is gone: it was +# `posterior_mean / pip` once the posterior mean moved onto `coef()`'s scale. # @noRd .projectPosteriorExtraCols <- function(tl) { csCols <- colnames(tl)[str_detect(colnames(tl), "^cs_[0-9.]+(_purity)?$")] @@ -1356,7 +1502,6 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { c( csCols, fullFitCols, - "conditional_effect", "lfsr", "method", "gene", @@ -1400,6 +1545,7 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { beta = .tlCol(tl, "marginal_beta", "numeric"), se = .tlCol(tl, "marginal_se", "numeric"), z = .tlCol(tl, "marginal_z", "numeric"), + z_supplied = .tlCol(tl, "marginal_z_supplied", "logical"), p = .tlCol(tl, "marginal_p", "numeric") ) } diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 3912b1b4..9c01a6f9 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -759,22 +759,16 @@ postprocessFinemappingFit.susiF <- function( ) } +# No try_fetch around the normalisation: `normalizeVariantId()` refuses only a +# non-CHARACTER `ids`, and all three sources here -- names(), colnames() and +# str_c() -- are character or NULL by construction. For character input it +# never throws; an id it cannot parse (an rsID, say) is returned unchanged, +# which is the behaviour the fallback was there to approximate. extractVariantNames <- function(fit) { variantNames <- names(fit$pip) %||% colnames(fit$alpha) %||% str_c("variant_", seq_along(fit$pip)) - try_fetch( - normalizeVariantId(variantNames), - error = function(cnd) { - msg <- glue( - "variant ids could not be normalised; using them as given. ", - "Downstream joins that assume the canonical form may not ", - "match." - ) - warn(msg, parent = cnd) - variantNames - } - ) + normalizeVariantId(variantNames) } extractSumstats <- function( @@ -845,13 +839,40 @@ selectEffects <- function(fit, priorEffTol = 1e-9) { } .asLbfMatrix <- function(fit) { - if (!is.null(fit$lbf_variable)) { - return(.asEffectMatrix(fit$lbf_variable)) + # Every shape a fit's per-effect LBF is known to arrive in, in one place. + # `lbf()` and colocPipeline used to keep separate lists of these and had + # drifted apart -- coloc was blind to a bare `fit$lBF`, which is exactly + # what an fSuSiE fit carries, so fSuSiE colocalization silently skipped. + nested <- if (is.list(fit) && length(fit) >= 1L) fit[[1L]] else NULL + # compact() drops NULL and zero-length entries, so the first survivor is + # the first shape the fit actually carries. + candidates <- compact(list( + .fitField(fit, "lbf_variable"), + .fitField(fit, "lBF"), + .fitField(fit, "fsusie_result", "lBF"), + .fitField(nested, "fsusie_result", "lBF") + )) + if (length(candidates) == 0L) { + return(NULL) } - if (!is.null(fit$lBF)) { - return(.asEffectMatrix(fit$lBF)) + .asEffectMatrix(candidates[[1L]]) +} + +# Read a nested fit field by path, tolerating every way the path can fail to +# exist. Neither `$` nor `[[` is safe here on its own: `$` errors on an atomic +# vector (a fit's first element is often a matrix) and `[[` errors on a name a +# list does not have. +# @noRd +.fitField <- function(x, ...) { + reduce(c(...), .fitFieldStep, .init = x) +} + +# @noRd +.fitFieldStep <- function(x, nm) { + if (!is.list(x) || !is_in(nm, names(x))) { + return(NULL) } - NULL + x[[nm]] } #' Compute Credible-Set Tables From a Fine-Mapping Fit @@ -1107,12 +1128,13 @@ setMethod( # Per-effect (per credible set) variant-level columns from the susie fit. Always # returns `within_cs_pip` (the variant's alpha in the single effect of its # assigned primary-coverage CS; NA for non-CS variants -- alpha is a -# probability, -# no scaling). With fullFit = TRUE it also widens the per-effect matrices, one -# column set per CS: `within_cs_pip_` (alpha) and -- unless -# perCsColumns = "full" -- `cs_logbf_` (lbf_variable), -# `cs_effect_` (mu / -# X_column_scale_factors) and `cs_effect_var_` ((mu2 - mu^2) / scale^2). +# probability, no scaling). +# +# `perCsColumns` then decides how much of the per-effect matrices is widened, +# one column set per CS: "none" stops at the scalar above, "alpha" adds +# `within_cs_pip_` (alpha), and "full" adds `cs_logbf_` +# (lbf_variable), `cs_effect_` (mu / X_column_scale_factors) and +# `cs_effect_var_` ((mu2 - mu^2) / scale^2) on top of it. # includeAllCs = TRUE widens EVERY effect (label `L`), else only effects that # produced a passing CS (label `cs`, matching the cs_ columns). # alpha/mu/mu2/lbf are L x p per-effect matrices (mu/mu2 already @@ -1550,7 +1572,7 @@ buildTopLoci <- function( cov <- .btlCoverage(csTables) fc <- .btlFitConstants(dataY, otherQuantities, region) post <- .btlPosterior(fit, conditionIdx, nV) - marg <- .btlMarginal(sumstats, nV) + marg <- .btlMarginal(sumstats, nV, af, n) cs <- .btlCsMembership(cov, csTables, nV, variantNames) fullFitBlock <- .btlFullFitBlock( fit, @@ -1632,11 +1654,7 @@ buildTopLoci <- function( withCond <- if (is.null(conditionIdx)) { out } else { - mutate( - out, - conditional_effect = cond$condEffect, - lfsr = cond$condLfsr - ) + mutate(out, lfsr = cond$condLfsr) } if (is.null(signalCutoff) || signalCutoff <= 0) { return(withCond) @@ -1718,19 +1736,65 @@ buildTopLoci <- function( ) } + +# The per-variant standardization factors susie divides its coefficients by, +# or 1 where the fit records none -- an RSS fit has no X to scale, and a fit +# run with `standardize = FALSE` records all-1s. Read with `[[`: `$` on a list +# falls back to prefix matching. +# @noRd +.btlScaleFactors <- function(fit, nV) { + sf <- fit[["X_column_scale_factors"]] + if (is.null(sf) || !is.numeric(sf) || length(sf) != nV) { + return(rep(1, nV)) + } + # A zero factor would divide to Inf; it can only come from a constant + # column, which carries no effect anyway. + replace(as.numeric(sf), !is.finite(sf) | sf == 0, 1) +} + +# susieInf / susieAsh carry an infinitesimal effect alongside the sparse one, +# and `coef.susie()` adds it in. Dropping it would silently change what the +# posterior effect means for those two methods. +# @noRd +.btlInfinitesimal <- function(fit, nV) { + theta <- fit[["theta"]] + if (is.null(theta) || !is.numeric(theta) || length(theta) != nV) { + return(rep(0, nV)) + } + replace(as.numeric(theta), !is.finite(theta), 0) +} + # Per-variant posterior mean/SD (from alpha, mu, mu2) and the strongest # single-effect log Bayes factor. A conditionIdx slices 3-D mvsusie mu/mu2. +# +# The mean and SD are returned on the scale of the X the fit was GIVEN, which +# means dividing the internal `colSums(alpha * mu)` by +# `X_column_scale_factors` -- exactly what `susieR::coef.susie()` does, and +# what `susieWeights()`, `.ctwasRenormalizeSusieWeights()` and the whole TWAS +# layer already return. Without the division this one column was the only +# quantity in the package on the standardized scale: the same fit yielded two +# different "posterior effects" depending on whether you read `topLoci()` or +# `susieWeights()`, and `weight_standardized` could not describe both. .btlPosterior <- function(fit, conditionIdx, nV) { alpha <- as.matrix(fit$alpha) mu <- .fmSliceCond(fit$mu, conditionIdx) mu2 <- .fmSliceCond(fit$mu2, conditionIdx) - postMean <- if (!is.null(mu) && all(dim(alpha) == dim(mu))) { - colSums(alpha * mu) + scaleFactors <- .btlScaleFactors(fit, nV) + meanStd <- if (!is.null(mu) && all(dim(alpha) == dim(mu))) { + colSums(alpha * mu) + .btlInfinitesimal(fit, nV) } else { rep(NA_real_, nV) } + postMean <- meanStd / scaleFactors postSd <- if (!is.null(mu2) && all(dim(alpha) == dim(mu2))) { - sqrt(pmax(colSums(alpha * mu2) - postMean^2, 0)) + # From the STANDARDIZED mean, then rescaled: an SD rescales the same + # way its mean does, but the mu2 identity only holds in the units mu2 + # is stored in. + sdStd <- sqrt(pmax( + colSums(alpha * mu2) - colSums(alpha * mu)^2, + 0 + )) + sdStd / scaleFactors } else { rep(NA_real_, nV) } @@ -1783,7 +1847,7 @@ buildTopLoci <- function( # Marginal univariate effects (beta, se, z, p) from the sumstats list; z and p # are derived when not supplied directly. -.btlMarginal <- function(sumstats, nV) { +.btlMarginal <- function(sumstats, nV, af = NULL, n = NULL) { beta <- if (!is.null(sumstats$betahat)) { as.numeric(sumstats$betahat) } else { @@ -1794,7 +1858,12 @@ buildTopLoci <- function( } else { rep(NA_real_, nV) } - z <- if (!is.null(sumstats$z)) { + # Whether the SOURCE supplied z matters downstream, not just its value: + # the GWAS-VCF `EZ` field is defined as the z "provided if it was used to + # derive the ES and SE fields", so a z we computed from a recorded + # beta/se must not be published as one that was provided. + zSupplied <- !is.null(sumstats$z) + z <- if (zSupplied) { as.numeric(sumstats$z) } else if (any(!is.na(beta)) && any(!is.na(se))) { beta / se @@ -1808,7 +1877,38 @@ buildTopLoci <- function( } else { rep(NA_real_, nV) } - list(beta = beta, se = se, z = z, p = p) + filled <- .btlFillFromZ(beta, se, z, af, n, nV) + list( + beta = filled$beta, + se = filled$se, + z = z, + p = p, + zSupplied = zSupplied + ) +} + +# A z-only source still has an effect size. .zToBetaSe() inverts the model +# (se = 1/sqrt(2*p*q*(N + z^2)), beta = z*se) given allele frequency and N, so +# leaving beta/se NA made every downstream effect-size consumer silently lose a +# GWAS that reported only z -- and such sources are routine. +# +# Only when NOTHING was recorded: filling the gaps in a partly-recorded column +# would mix measured and model-derived values under one name. `af` rather than +# maf is fine, since the 2*p*q variance term is symmetric in p <-> q. +# @noRd +.btlFillFromZ <- function(beta, se, z, af, n, nV) { + asIs <- list(beta = beta, se = se) + if (any(!is.na(beta)) || all(is.na(z))) { + return(asIs) + } + if (is.null(af) || is.null(n) || anyNA(af) || anyNA(n)) { + return(asIs) + } + if (length(af) != nV || !is_in(length(n), c(1L, nV))) { + return(asIs) + } + bs <- .zToBetaSe(z, af, n) + list(beta = as.numeric(bs$beta), se = as.numeric(bs$se)) } # CS membership index + purity for every coverage present (high -> low), with @@ -1857,29 +1957,6 @@ buildTopLoci <- function( ) } -# Per-condition conditional effect (coef / pip) for a multi-condition fit. -# Accepts a trimmed fit's `$coef` or a raw mvsusie fit via coef.mvsusie(). -.btlCondEffect <- function(fit, method, conditionIdx, nV) { - coefMat <- if (!is.null(fit$coef)) { - as.matrix(fit$coef) - } else if ( - identical(method, "mvsusie") && - requireNamespace("mvsusieR", quietly = TRUE) - ) { - cm <- try_fetch(mvsusieR::coef.mvsusie(fit), error = function(cnd) NULL) - if (!is.null(cm)) as.matrix(cm)[-1L, , drop = FALSE] else NULL - } else { - NULL - } - if ( - is.null(coefMat) || nrow(coefMat) != nV || ncol(coefMat) < conditionIdx - ) { - return(rep(NA_real_, nV)) - } - pipVec <- as.numeric(fit$pip) - if_else(pipVec > 0, coefMat[, conditionIdx] / pipVec, NA_real_) -} - # Per-condition conditional lfsr: map each variant to its effect (L) via the # primary (highest-coverage) credible set, then read that effect's lfsr. .btlCondLfsr <- function( @@ -1890,7 +1967,9 @@ buildTopLoci <- function( csTables, nV ) { - clf <- if (!is.null(fit$clfsr)) fit$clfsr else fit$conditional_lfsr + # `%||%` not `if (!is.null(...))`: three sources in priority order, the + # last of which COMPUTES the quantity a univariate fit never reports. + clf <- fit$clfsr %||% fit$conditional_lfsr %||% .btlUnivariateClfsr(fit) condLfsr <- rep(NA_real_, nV) if ( is.null(clf) || @@ -1938,6 +2017,38 @@ buildTopLoci <- function( # One credible set's conditional-lfsr values, or NULL when its effect is out # of range or it covers no in-range variant. # @noRd +# The conditional lfsr of a univariate susie fit, which reports none. +# +# It has everything needed to compute one: the single-effect posterior for +# variant j in effect l is N(mu[l, j], mu2[l, j] - mu[l, j]^2), so the +# probability of a SIGN error conditional on that variant carrying the effect +# is pnorm(-|mu| / sd). That is the same quantity mvSuSiE reports in `clfsr`, +# for the one condition a univariate fit has -- so it comes back in the same +# [effect, variant, condition] shape and flows through the identical credible +# set assignment, rather than needing a parallel code path. +# +# NULL (hence NA downstream, as before) when the fit was trimmed of mu / mu2. +# @noRd +.btlUnivariateClfsr <- function(fit) { + mu <- fit$mu + mu2 <- fit$mu2 + if (is.null(mu) || is.null(mu2)) { + return(NULL) + } + mu <- as.matrix(mu) + mu2 <- as.matrix(mu2) + if (!identical(dim(mu), dim(mu2)) || length(dim(mu)) != 2L) { + return(NULL) + } + # Numerical slop can make mu2 - mu^2 very slightly negative. + sd <- sqrt(pmax(mu2 - mu^2, 0)) + lfsr <- stats::pnorm(-abs(mu) / sd) + # A zero-variance single effect is degenerate rather than sign-certain, so + # it reports nothing instead of a confident 0. + lfsr[sd <= 0 | !is.finite(lfsr)] <- NA_real_ + array(lfsr, dim = c(dim(mu), 1L)) +} + .btlCondLfsrForSet <- function( csPos, setsPrim, @@ -1969,13 +2080,9 @@ buildTopLoci <- function( nV ) { if (is.null(conditionIdx)) { - return(list( - condEffect = rep(NA_real_, nV), - condLfsr = rep(NA_real_, nV) - )) + return(list(condLfsr = rep(NA_real_, nV))) } list( - condEffect = .btlCondEffect(fit, method, conditionIdx, nV), condLfsr = .btlCondLfsr( fit, conditionIdx, @@ -2078,6 +2185,7 @@ buildTopLoci <- function( marginal_beta = unname(marg$beta), marginal_se = unname(marg$se), marginal_z = unname(marg$z), + marginal_z_supplied = isTRUE(marg$zSupplied), marginal_p = unname(marg$p), pip = as.numeric(fit$pip), posterior_mean = unname(post$postMean), @@ -2116,6 +2224,7 @@ buildTopLoci <- function( marginal_beta = numeric(), marginal_se = numeric(), marginal_z = numeric(), + marginal_z_supplied = logical(), marginal_p = numeric(), pip = numeric(), posterior_mean = numeric(), @@ -2137,6 +2246,18 @@ 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 || @@ -4314,7 +4435,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { ctx, tid, af, - fitRetention + fitRetention, + region = NULL ) { fit <- .fmXFitOne( tk, @@ -4338,7 +4460,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { y = y, credibleSetParam = credibleSetParam, af = af, - fitRetention = fitRetention + fitRetention = fitRetention, + region = region ) } @@ -4357,7 +4480,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { ctx, tid, af, - fitRetention + fitRetention, + region = NULL ) { chainLocal <- .fmResolveSusieChain(toRun, initializeWithSusieInf) infFit <- .fmXInfFit( @@ -4384,7 +4508,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { ctx = ctx, tid = tid, af = af, - fitRetention = fitRetention + fitRetention = fitRetention, + region = region ), toRun )) @@ -4405,7 +4530,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { samplePartition = NULL, af = NULL, fitRetention = "slim", - seed = NULL + seed = NULL, + region = NULL ) { out <- .fmXFitAll( toRun, @@ -4418,7 +4544,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { ctx = ctx, tid = tid, af = af, - fitRetention = fitRetention + fitRetention = fitRetention, + region = region ) .fmXCrossValidate( out, @@ -4516,7 +4643,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { y, credibleSetParam, af, - fitRetention + fitRetention, + region = NULL ) { .fmPostprocessOne( fit = fit, @@ -4524,6 +4652,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { dataX = X, dataY = y, af = af, + region = region, csInput = "X", credibleSetParam = credibleSetParam, fitRetention = fitRetention @@ -4596,7 +4725,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { af = NULL, nVar = NULL, fitRetention = "slim", - susieRssParam + susieRssParam, + region = NULL ) { chainLocal <- .fmResolveSusieChain(toRun, initializeWithSusieInf) infFit <- .fmRssInfFit( @@ -4626,7 +4756,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { label = label, af = af, nVar = nVar, - fitRetention = fitRetention + fitRetention = fitRetention, + region = region ), toRun )) @@ -4649,7 +4780,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { label, af, nVar, - fitRetention + fitRetention, + region = NULL ) { f <- .fmRssFitOne( tk, @@ -4674,7 +4806,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { credibleSetParam = credibleSetParam, af = af, nVar = nVar, - fitRetention = fitRetention + fitRetention = fitRetention, + region = region ) if (f$isStd && isTRUE(susieRssParam$serFallback)) { return(.fmRssRecordFallback(entry, f, susieRssParam$keepFullFit)) @@ -4839,7 +4972,8 @@ extractTopPipInfo <- function(fmRow, sumstats) { credibleSetParam, af, nVar, - fitRetention + fitRetention, + region = NULL ) { .fmPostprocessOne( fit = fit, @@ -4851,6 +4985,7 @@ extractTopPipInfo <- function(fmRow, sumstats) { # path that has no per-variant N -> buildTopLoci leaves N as NA, # never 1. This is NOT `n` (the scalar median the RSS fit consumes). n = nVar, + region = region, csInput = "Xcorr", credibleSetParam = credibleSetParam, fitRetention = fitRetention diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index e9a3694f..01377306 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -507,6 +507,7 @@ setMethod("varY", "GwasSumStats", function(x, studyName = NULL) { if (is.na(val)) NULL else val }) + # ============================================================================= # Coercion / converters # ============================================================================= diff --git a/R/jointEngine.R b/R/jointEngine.R index 2a589a22..fce1a4ea 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -252,6 +252,56 @@ NULL # ---- fitters (fitJointGroup) ------------------------------------------------ +# The window a joint group was analysed over. An explicit region wins; failing +# that the group's traits define it, as the union span of their own cis +# windows -- one joint fit over several traits covers all of them. +# @noRd +.jointGroupWindow <- function(data, cond, args) { + explicit <- .asAnalysisWindow(args$region) + if (!is.null(explicit)) { + return(explicit) + } + per <- try_fetch( + .anchorVector( + data, + as.character(cond$context), + as.character(cond$trait), + "region", + args$cisWindow + ), + error = function(cnd) NULL + ) + if (is.null(per) || length(per) == 0L) { + return(NULL) + } + range(per)[1L] +} + + +# Per-variant allele frequency for a joint group's design matrix, or NULL. +# +# The univariate/RSS paths pass `af` into postprocessFinemappingFits(); the +# joint ones did not, so every mvsusie / fsusie row exported af = NA (and +# therefore maf = NA) even though the genotypes were right there. The window is +# 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) { + if (!is(g, "IndividualJointGroup")) { + return(NULL) + } + X <- .jgX(g) + if (is.null(X) || ncol(X) == 0L) { + return(NULL) + } + rg <- try_fetch(.csVariantRegion(colnames(X)), error = function(cnd) NULL) + if (is.null(rg)) { + return(NULL) + } + .fmAfForX(data, X, region = rg) +} + + # (individual, fine-mapping) -> mvSuSiE joint fit + honest per-fold CV prior. setMethod( "fitJointGroup", @@ -323,7 +373,9 @@ setMethod( fit = fit, cvM = cvM, Xc = Xc, - cfg = cfg + cfg = cfg, + af = args$af, + region = args$region ) # ONE entry for the whole joint fit, unlike mvsusie's one-per-condition. # mvsusie's posteriors carry a conditions axis, so .fmSliceCond() gives @@ -374,13 +426,17 @@ setMethod( Xc, cfg, credibleSetParam, - fitRetention + fitRetention, + af = NULL, + region = NULL ) { bare <- .fmPostprocessOne( fit = fit, method = "fsusie", dataX = Xc, dataY = NULL, + af = af, + region = region, conditionIdx = r, csInput = "fsusie", credibleSetParam = cfg$credibleSetParam, @@ -425,7 +481,9 @@ setMethod( Xc = Xc, keep = keep, survivors = survivors, - cfg = cfg + cfg = cfg, + af = args$af, + region = args$region ) } @@ -551,7 +609,9 @@ setMethod( survivors, cfg, credibleSetParam, - fitRetention + fitRetention, + af = NULL, + region = NULL ) { if (!keep[i]) { return(NULL) @@ -562,6 +622,8 @@ setMethod( method = "mvsusie", dataX = Xc, dataY = NULL, + af = af, + region = region, conditionIdx = r, csInput = "X", credibleSetParam = cfg$credibleSetParam, @@ -605,7 +667,8 @@ setMethod( .jointRssEntry, fit = fit, ldMat = ldMat, - cfg = cfg + cfg = cfg, + region = args$region ) } ) @@ -656,12 +719,13 @@ setMethod( # `credibleSet` / `fitRetention` come off `cfg`, which is what the caller # supplies; they were also declared as formals with no defaults, so nothing # could ever have passed them without erroring. `group` was unused too. -.jointRssEntry <- function(r, fit, ldMat, cfg) { +.jointRssEntry <- function(r, fit, ldMat, cfg, region = NULL) { .fmPostprocessOne( fit = fit, method = "mvsusie", dataX = ldMat, dataY = NULL, + region = region, conditionIdx = r, csInput = "Xcorr", credibleSetParam = cfg$credibleSetParam, @@ -1917,9 +1981,20 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { cond = cond, js = .jointAxisMembers(cond, "study"), jc = .jointAxisMembers(cond, "context"), - jt = .jointAxisMembers(cond, "trait") + jt = .jointAxisMembers(cond, "trait"), + # The window this group was analysed over: the caller's region when + # one was named, else the group's own cis window (the union span of + # its traits +/- cisWindow). Recorded because the fit only ever sees + # whichever variants survived QC; read back by genomicRegion(). + region = .jointGroupWindow(data, cond, args) ) fitArgs <- .twasGroupArgs(g, pipeline, args) + # Provenance the fitters cannot recover for themselves: `data` lives here + # but not inside fitJointGroup(), and the requested window is only ever + # known to the caller. Both are read back as args$af / args$region where + # the entries are post-processed. + fitArgs$af <- .jointAfForGroup(data, g) + fitArgs$region <- args$region perTokenEntries <- compact(set_names( map( tokens, @@ -2576,7 +2651,8 @@ setMethod("construct", "TwasJointPipeline", function(pipeline, records) { jointStudies = grp$js, jointContexts = grp$jc, jointTraits = grp$jt, - traitPos = tpos + traitPos = tpos, + region = grp$region ) } diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 1f2ecb6c..3030c80e 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -2405,7 +2405,12 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataType = weightsDataType, crossValidationArgs = .cvResolve(CrossValidationParam()), fitFullData = TRUE, - standardized = FALSE, + # What the accessor will actually do on this path. No + # residualization bundle reaches the TWAS joint dispatcher, so + # `residualizedGenotypes()` falls back to the dataset's own + # `scaleResiduals` slot -- which is therefore the honest answer + # here, and `NULL` says that explicitly rather than by omission. + standardized = .qtlScaleResiduals(data, NULL), seed = seed, ldSketch = NULL ) diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index 9ce30d67..f3f909f7 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -484,11 +484,21 @@ NULL )) } 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' string, a GRanges, or a ", - "one-row data.frame with chrom/start/end." + "`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) } @@ -866,6 +876,11 @@ NULL } else { as.numeric(df[[z$betaSrc]]) / as.numeric(df[[z$seSrc]]) }, + # Whether the SOURCE supplied z, which is what GWAS-VCF's `EZ` means. + # Recorded here because this is the only place that still knows: past + # it, a supplied z and a Wald z computed from beta/se are both just + # `Z`. + z_supplied = z$hasZ, !!!.sumstatSampleSizeCols(df, n), !!!map(present, .sumstatNumericColumn, df = df) ) @@ -915,12 +930,37 @@ NULL } # Default GWAS-VCF FORMAT tag mapping (canonical stat -> FORMAT field). +# Candidate FORMAT keys per field, in priority order: the GWAS-VCF reserved +# key first, then spellings found in the wild. +# +# `N` used to be `"SS"` alone -- which is NOT a GWAS-VCF key; the spec's +# sample-size field is `NS`. The writer emitted `SS` too, so the two +# round-tripped with each other while neither conformed, and fixing the writer +# would have broken this reader on pecotmr's own output. `SS` stays as a +# fallback because files in the wild use it. +# @noRd .gwasVcfFormatDefaults <- list( BETA = "ES", SE = "SE", + # `EZ` is the z the SOURCE supplied -- the spec defines it as the z + # "provided if it was used to derive the ES and SE fields". Reading it was + # missing entirely, so a z-derived study round-tripped as though pecotmr + # had computed its z from ES/SE. + Z = "EZ", P = "LP", - N = "SS", - MAF = "EAF" + N = c("NS", "SS"), + # `AF` is the spec's ALTERNATIVE-allele frequency: DIRECTIONAL, and the + # one the posterior view publishes as `af`. It used to be read as a + # fallback for the MAF slot and then folded with pmin(af, 1 - af), so an + # AF of 0.8 came back as a MAF of 0.2 with no `AF` column at all -- + # pecotmr's own VCF output did not round-trip, and the direction the + # standardized-to-raw weight conversion needs was silently gone. The + # mirror of the released writer bug where `AF` held MAF. + AF = "AF", + # `EAF` stays with MAF deliberately, matching the delimited-table loader: + # a column calling itself an effect-allele frequency is not auto-trusted + # as directional, because the effect allele it refers to is not stated. + MAF = c("MAF", "EAF") ) # Pick the FORMAT sample column of a GWAS-VCF to read. Defaults to the single @@ -950,14 +990,18 @@ NULL # Read column `tag` from the GWAS-VCF geno matrix for one sample as numeric, or # NULL when the tag is absent/unmapped. # @noRd +# `tag` may name SEVERAL candidate keys in priority order (the spec's key then +# the spellings found in the wild), so the first one the file actually carries +# wins. A single string still works -- it is a length-1 candidate list. +# @noRd .vcfGetField <- function(tag, geno, sample) { - if (!is.null(tag) && is_in(tag, names(geno))) { - # unname: geno matrix columns carry variant-id element names that the - # canonical sumstat tibble must not keep (data.frame stripped them). - unname(as.numeric(geno[[tag]][, sample])) - } else { - NULL + hit <- intersect(as.character(tag %||% character(0)), names(geno)) + if (length(hit) == 0L) { + return(NULL) } + # unname: geno matrix columns carry variant-id element names that the + # canonical sumstat tibble must not keep (data.frame stripped them). + unname(as.numeric(geno[[hit[[1L]]]][, sample])) } # Convert a VCF (GWAS-VCF format) into the canonical sumstats data.frame. The @@ -978,42 +1022,76 @@ NULL sample <- .pickVcfSample(colnames(vcf), sampleSelect, label) es <- .vcfGetField(fmap$BETA, geno, sample) se <- .vcfGetField(fmap$SE, geno, sample) + ez <- .vcfGetField(fmap$Z, geno, sample) lp <- .vcfGetField(fmap$P, geno, sample) ss <- .vcfGetField(fmap$N, geno, sample) + af <- .vcfGetField(fmap$AF, geno, sample) eaf <- .vcfGetField(fmap$MAF, geno, sample) - if (is.null(es) || is.null(se)) { + if ((is.null(es) || is.null(se)) && is.null(ez)) { msg <- glue( - "{label}: GWAS-VCF must carry ES and SE FORMAT fields to derive ", - "Z (configure via `formatMapping`)." + "{label}: GWAS-VCF must carry either a supplied z (EZ) or ES and ", + "SE to derive one from (configure via `formatMapping`)." ) abort(msg) } if (is.null(ss)) { msg <- glue( - "{label}: GWAS-VCF must carry an SS (sample size) FORMAT field." + "{label}: GWAS-VCF must carry a sample-size FORMAT field ", + "(NS, or SS in older files; configure via `formatMapping`)." ) abort(msg) } + z <- .vcfSumstatZ(es, se, ez, length(rr)) out <- tibble( chrom = as.character(GenomicRanges::seqnames(rr)), pos = unname(as.integer(GenomicRanges::start(rr))), SNP = names(rr), A1 = alt, A2 = ref, - Z = es / se, - N = ss, - BETA = es, - SE = se + Z = z$z, + z_supplied = z$supplied, + N = ss ) mutate( out, !!!compact(list( + BETA = es, + SE = se, P = if (!is.null(lp)) 10^(-lp), - MAF = if (!is.null(eaf)) pmin(eaf, 1 - eaf) + AF = af, + # A directionless MAF of its own when the file has one; else + # folded from AF, which is QC-usable and keeps `AF` intact + # alongside it rather than consuming it. + MAF = if (!is.null(eaf)) { + pmin(eaf, 1 - eaf) + } else if (!is.null(af)) { + pmin(af, 1 - af) + } )) ) } +# The z and its provenance, per variant. A supplied `EZ` wins where it has a +# value; elsewhere the Wald z is derived from ES / SE. Per VARIANT rather than +# per file because a field declared in the header can be absent from +# individual records, and publishing a derived z as a supplied one would tell +# a reader that ES and SE came from it. +# @noRd +.vcfSumstatZ <- function(es, se, ez, n) { + derived <- if (is.null(es) || is.null(se)) { + rep(NA_real_, n) + } else { + es / se + } + if (is.null(ez)) { + return(list(z = derived, supplied = rep(FALSE, n))) + } + list( + z = if_else(is.na(ez), derived, ez), + supplied = !is.na(ez) + ) +} + # Read one GWAS-VCF sumstats file (region-restricted only when bgzipped + # tabix-indexed) into the canonical sumstats data.frame. .readSumStatsVcf <- function(path, region, sampleSelect, formatMapping, label) { diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 87bf9359..272dd66f 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -48,7 +48,6 @@ } - # The per-variant top-loci columns of one side as a tibble -- topLoci() # returns ranges, and mcols() is exactly the pre-conversion table. # @noRd @@ -64,8 +63,8 @@ #' \code{GwasFineMappingResult} on shared variants, matched with pecotmr's #' allele-aware \code{matchVariants} (handling strand flips / ref-alt swaps #' rather than naive id equality). The GWAS side is harmonized to the QTL -#' orientation: its signed effect columns (\code{beta}, \code{z}, -#' \code{conditional_effect}) are sign-flipped and its effect-allele frequency +#' orientation: its signed effect columns (\code{posterior_effect}, +#' \code{beta}, \code{z}) are sign-flipped and its effect-allele frequency #' (\code{af}) is complemented wherever a swap occurred. The result keeps the #' variant key columns once (from the QTL, the reference orientation) and #' prefixes every other column \code{qtl_} / \code{gwas_}. A variant shared @@ -167,7 +166,11 @@ setMethod( # @noRd .overlapRelabelGwas <- function(gwasTl, vmap, coordCols) { joined <- inner_join(gwasTl, vmap, by = c("variant_id" = "gwas_vid")) - signedCols <- c("beta", "z", "conditional_effect") + # `posterior_effect` FIRST: it is what topLoci() actually publishes, and + # `any_of()` below skips a name it does not find SILENTLY -- so omitting it + # left a swapped variant's posterior effect with the wrong sign and no + # error. `beta`/`z` stay for a marginal-view frame. + signedCols <- c("posterior_effect", "beta", "z") # Bound with partial() rather than across()'s deprecated `...`; the local # matters because partial() resolves it lazily (see .negateWhere et al). rowSign <- joined$.sign diff --git a/R/resultReaders.R b/R/resultReaders.R new file mode 100644 index 00000000..b42ebca4 --- /dev/null +++ b/R/resultReaders.R @@ -0,0 +1,1296 @@ +# ============================================================================= +# 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 +# vocabulary -- and rebuild the S4 collection. +# +# readFineMappingResult(path, ...) -> Qtl / GwasFineMappingResult +# readTwasWeights(path, ...) -> TwasWeights +# +# Two rules shape everything here. +# +# PERMISSIVE about columns. Each consumer needs a different few: TWAS needs +# only the weight, Mendelian randomization beta/se/PIP, colocalization the LBF +# matrix on its non-enloc path. A file converted from another tool will carry +# some of those and not others, so a missing column is restored as absent, not +# as an error -- the consumers name what they lack when they are reached. +# What IS required is only what the class itself cannot exist without: a +# coordinate-encoding variant id, and for a fine-mapping result a PIP. +# +# STRICT about identity. A merged table holding several (study, context, +# trait, method) tuples reads back as a multi-row collection, one row per +# tuple. Where a per-row value is recorded per variant -- the analysis window, +# the provenance flags -- every variant of a tuple must agree, and a +# disagreement is an error: it means two different results were concatenated +# under one identity, and picking either value would silently publish one +# fit's window over another's. +# ============================================================================= + +#' @include AllGenerics.R AllClasses.R resultWriters.R +#' @importFrom dplyr slice mutate select bind_cols all_of +#' @importFrom tibble tibble as_tibble +#' @importFrom purrr map map_chr map_lgl list_rbind compact set_names +#' @importFrom stringr str_c str_detect str_remove str_to_lower +#' @importFrom stringr str_flatten str_split_1 +#' @importFrom magrittr is_in +#' @importFrom glue glue +#' @importFrom dplyr if_else +#' @importFrom rlang abort warn arg_match try_fetch .data +#' @importFrom checkmate assertString assertFlag +NULL + +# ---- the inverse of the published vocabulary -------------------------------- + +# Published column -> the CANONICAL WIDE `topLoci` column it was projected +# from. Only the pure renames live here. The four quantities that are +# TRANSFORMED on the way out are inverted explicitly below, each next to a +# comment naming the forward transform: `start`/`end` from `pos`, `LP` from +# `p`, `EZ` with its supplied flag, and `CS` from the credible-set label. +# +# `MAF` has no canonical slot -- the posterior view publishes `af`, the +# directional frequency -- so it is restored under its own name and travels as +# a passthrough column rather than being mistaken for `af`. +# @noRd +.PUB_RESTORE_VARIANT <- c( + `#chr` = "chrom", + ID = "variant_id", + REF = "A2", + ALT = "A1", + AF = "af", + MAF = "maf", + NS = "N", + ES = "marginal_beta", + SE = "marginal_se", + WGT = "posterior_mean", + WGTSE = "posterior_sd", + PIP = "pip", + LBF = "logBF", + LFSR = "lfsr" +) + +# Published column -> the collection mcols column it was read from. These are +# per-ROW, so they are lifted out of the variant table and reconciled across +# each tuple's variants rather than stored per variant. +# @noRd +.PUB_RESTORE_IDENTITY <- c( + study = "study", + context = "context", + trait = "trait", + method = "method", + block_id = "blockId", + data_type = "dataType", + data_source = "dataSource", + weight_standardized = "standardized", + joint_studies = "jointStudies", + joint_contexts = "jointContexts", + joint_traits = "jointTraits" +) + +# The published columns that are structural or per-row, and so are never +# carried through as a variant-level passthrough column. +# @noRd +.PUB_NON_PAYLOAD <- c( + "#chr", + "start", + "end", + "region_id", + "region_start", + "region_end", + names(.PUB_RESTORE_IDENTITY) +) + +# The identity axes a published table is grouped into collection rows by. +# @noRd +.PRD_GROUP_COLS <- c("study", "context", "trait", "method", "block_id") + +# ---- reading the file ------------------------------------------------------- + +# One published table as a tibble of character columns, region-restricted when +# the file is bgzipped + tabix-indexed. +# +# Every column is read as character and coerced afterwards, for the same +# reason `.readTabixRegion()` does it: an allele or id column that happens to +# be uniformly "T" within a region would otherwise be type-guessed as logical, +# silently corrupting the variant identity. +# @noRd +.prdReadTable <- function(path, region, label) { + if (!file.exists(path)) { + abort(glue("{label}: file '{path}' does not exist.")) + } + if (!is.null(region)) { + if (file.exists(str_c(path, ".tbi"))) { + return(.readTabixRegion(path, region)) + } + warn(glue( + "{label}: '{path}' is not bgzipped + tabix-indexed; `region` ", + "ignored, reading the whole file." + )) + } + readr::read_tsv( + path, + show_col_types = FALSE, + progress = FALSE, + col_types = readr::cols(.default = readr::col_character()) + ) +} + +# Which reader a path asks for. The writers choose the extension, so `"auto"` +# is unambiguous on pecotmr's own output; `format` is for a file named +# something else. +# @noRd +.prdFormat <- function(path, format) { + format <- arg_match(format, c("auto", "bed", "vcf")) + if (format != "auto") { + return(format) + } + stem <- str_remove(path, "\\.(gz|bgz|bz2)$") + if (str_detect(stem, "\\.(vcf|bcf)$")) "vcf" else "bed" +} + +# ---- reading a published VCF ------------------------------------------------ + +# One published GWAS-VCF as the SAME long table the BED reader produces: the +# structural columns, one column per FORMAT key, and the identity columns read +# 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) + samples <- colnames(vcf) + if (!is.null(sampleSelect)) { + absent <- setdiff(as.character(sampleSelect), samples) + if (length(absent) > 0L) { + abort(glue( + "{label}: sampleSelect names {str_flatten(absent, ', ')}, ", + "which the VCF does not have (have: ", + "{str_flatten(samples, ', ')})." + )) + } + samples <- as.character(sampleSelect) + } + if (length(samples) == 0L) { + # A sites-only VCF -- no FORMAT, no sample columns -- carries no + # per-variant statistics at all. Returning an empty table instead + # only defers the failure to whichever required column is missed + # first, which reported "no `PIP` column" for a file whose real + # problem is that it holds no results. + abort(glue( + "{label}: the VCF has no samples, so it carries no published ", + "results. A published file records each result as a sample ", + "with its own FORMAT fields." + )) + } + meta <- .prdVcfSampleMeta(vcf) + pieces <- map(samples, .prdVcfSampleTable, vcf = vcf, meta = meta) + list( + table = list_rbind(pieces), + fits = compact(set_names( + map(samples, .prdVcfPartialFit, meta = meta), + map_chr(pieces, .prdFirstKey) + )) + ) +} + +# 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. +# @noRd +.prdFirstKey <- function(tbl) { + cols <- intersect(.PRD_GROUP_COLS, names(tbl)) + if (nrow(tbl) == 0L || length(cols) == 0L) { + return("") + } + .pubIdentityKey(tbl, cols)[[1L]] +} + +# @noRd +.prdReadVcf <- function(path, region, label) { + if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { + abort(glue( + "{label}: reading a published VCF requires the ", + "'VariantAnnotation' package." + )) + } + 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)) { + warn(glue( + "{label}: '{path}' is not bgzipped + tabix-indexed; ", + "`region` ignored, reading the whole file." + )) + } + return(VariantAnnotation::readVcf(path)) + } + tf <- Rsamtools::TabixFile(path) + gr <- .matchRegionSeqnames( + .asGRegion(region), + Rsamtools::seqnamesTabix(tf) + ) + if (is.null(gr)) { + return(VariantAnnotation::readVcf(path)[0, ]) + } + VariantAnnotation::readVcf(tf, param = gr) +} + +# 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 +# identity, the analysis window and the two per-EFFECT fit quantities (`V`, +# `cs_index`) that no per-variant column could hold. +# @noRd +.prdVcfSampleMeta <- function(vcf) { + # `meta()` is VariantAnnotation's own accessor for the header's structured + # `##` blocks -- S4Vectors::metadata() is a different thing and returns + # nothing here. + md <- try_fetch( + VariantAnnotation::meta(VariantAnnotation::header(vcf))$SAMPLE, + error = function(cnd) NULL + ) + if (is.null(md) || nrow(md) == 0L) { + return(NULL) + } + df <- as.data.frame(md, stringsAsFactors = FALSE) + # Back to the shared vocabulary through the writer's own table, so the + # rest of the reader sees the same names a published BED carries. + known <- is_in(names(df), .PUB_SAMPLE_KEYS) + names(df)[known] <- names(.PUB_SAMPLE_KEYS)[ + match(names(df)[known], .PUB_SAMPLE_KEYS) + ] + df +} + +# One sample's rows: the fixed columns, its FORMAT values, and the identity +# the header recorded for it. +# @noRd +.prdVcfSampleTable <- function(sample, vcf, meta) { + rr <- SummarizedExperiment::rowRanges(vcf) + n <- length(rr) + geno <- VariantAnnotation::geno(vcf) + fixed <- tibble( + `#chr` = as.character(GenomicRanges::seqnames(rr)), + start = as.integer(GenomicRanges::start(rr)) - 1L, + 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)) + ) + 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) +} + +# 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 +.prdVcfFormatColumn <- function(key, geno, sample) { + m <- geno[[key]] + if (!is_in(sample, colnames(m))) { + return(rep(NA_character_, nrow(m))) + } + v <- as.character(unname(m[, sample])) + # A `Number=A` geno field comes back as a CHARACTER matrix whose missing + # cells are the literal strings "NA" (or VCF's own "."), not NA. Left in + # place they stop a numeric field from being recognised as numeric, which + # is how a published Float came back as a character column. + replace(v, !is.na(v) & is_in(v, c("NA", ".", "")), NA_character_) +} + +# 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 +# FORMAT key is conventionally uppercase, and nothing else in the schema is +# case-ambiguous. +# @noRd +.prdVcfKeyName <- function(key) { + lower <- str_to_lower(key) + if (str_detect(lower, "^(within_cs_pip|cs_logbf_|cs_effect_)")) { + return(lower) + } + key +} + +# The identity columns for one sample, recycled over its variants. +# +# A file with no `##SAMPLE` block still has the sample NAME. Splitting it back +# into a tuple would be guesswork, but taking it whole is not: it becomes the +# `study`, which keeps each sample a result of its own rather than letting +# several merge into one identity-less row, and the reader's own arguments +# supply whatever else is wanted. +# @noRd +.prdVcfIdentity <- function(meta, sample, n) { + if (is.null(meta) || !is_in(sample, rownames(meta))) { + return(tibble(study = rep(sample, length.out = n))) + } + row <- meta[sample, , drop = FALSE] + cols <- intersect( + c( + names(.PUB_RESTORE_IDENTITY), + "region_id", + "region_start", + "region_end" + ), + colnames(row) + ) + if (length(cols) == 0L) { + return(tibble(study = rep(sample, length.out = n))) + } + out <- as_tibble( + set_names(map(cols, .prdMetaValue, row = row, n = n), cols), + .name_repair = "minimal" + ) + .prdVcfRegionStart(out) +} + +# 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 +# the readers share settles on the table's convention and the VCF value is +# shifted into it here -- once, rather than at every reader of the column. +# @noRd +.prdVcfRegionStart <- function(out) { + if (!is_in("region_start", names(out))) { + return(out) + } + mutate( + out, + region_start = as.character( + suppressWarnings(as.integer(.data$region_start)) - 1L + ) + ) +} + +# One header field's value, recycled over the sample's variants. "." is VCF's +# 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) { + v <- as.character(row[[nm]][[1L]]) + rep(if (!is.na(v) && v == ".") NA_character_ else v, length.out = n) +} + +# The per-effect fit quantities the `##SAMPLE` block carried, as the partial +# `susieFit` of one row -- `V` (the estimated prior variances) and the credible +# sets' `cs_index`. They are per EFFECT, not per variant, which is why they +# live in the header at all, and colocalization's credible-set filter reads +# them straight off the fit. Everything else a fit holds (alpha, lbf_variable, +# 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"]]) + out <- compact(list( + V = v, + sets = if (!is.null(csIndex)) list(cs_index = as.integer(csIndex)) + )) + if (length(out) == 0L) NULL else out +} + +# A ";"-packed header value as a numeric vector, or NULL when it was NA. +# @noRd +.prdUnpackNumeric <- function(cell) { + if (is.null(cell) || length(cell) == 0L) { + return(NULL) + } + chr <- as.character(cell[[1L]]) + if (length(chr) == 0L || is.na(chr) || chr == "") { + return(NULL) + } + suppressWarnings(as.numeric(str_split_1(chr, ";"))) +} + +# ---- published table -> canonical per-variant table ------------------------- + +# The canonical wide `topLoci` table for one published table: the pure renames +# applied, the four transformed quantities inverted, and every other column +# carried through verbatim so a `columns = "all"` export and a third party's +# own annotations both survive the trip. +# @noRd +.prdCanonical <- function(df, method, priorVariance) { + pos <- .prdPos(df) + out <- tibble( + variant_id = .prdVariantIds(df, pos), + chrom = .prdChr(df), + pos = pos + ) + renamed <- intersect(names(.PUB_RESTORE_VARIANT), names(df)) + renamed <- setdiff(renamed, c("#chr", "ID")) + out <- bind_cols( + out, + as_tibble( + set_names( + map(renamed, .prdRestoreColumn, df = df), + .PUB_RESTORE_VARIANT[renamed] + ), + .name_repair = "minimal" + ) + ) + out <- bind_cols( + out, + .prdMarginalZ(df), + .prdMarginalP(df), + .prdCsColumns(df, method), + .prdPassthrough(df) + ) + .prdWakefieldLbf(out, priorVariance) +} + +# A published column restored to its canonical name, typed. Everything the +# renaming table covers is numeric except the four character columns, which +# are the alleles and the id-like fields. +# @noRd +.prdRestoreColumn <- function(nm, df) { + v <- df[[nm]] + if (is_in(nm, c("REF", "ALT"))) { + return(as.character(v)) + } + suppressWarnings(as.numeric(v)) +} + +# The 1-based position. A published range is 0-based half-open -- that is the +# BED format's requirement -- so `end` IS the 1-based position of a +# single-base record, and `start + 1` says the same thing. `end` is preferred +# because it is what the writer set from `pos` directly. +# @noRd +.prdPos <- function(df) { + if (is_in("end", names(df))) { + return(suppressWarnings(as.integer(df$end))) + } + if (is_in("start", names(df))) { + return(suppressWarnings(as.integer(df$start)) + 1L) + } + rep(NA_integer_, nrow(df)) +} + +# @noRd +.prdChr <- function(df) { + if (is_in("#chr", names(df))) { + return(as.character(df[["#chr"]])) + } + rep(NA_character_, nrow(df)) +} + +# The variant ids, which are the one thing a result cannot be built without: +# an id renders a range and its alleles, so `.variantIdsToGRanges()` refuses +# one that does not encode coordinates. A published `ID` normally does, having +# been written from exactly that. When it does not -- an rsid-keyed file from +# another tool -- the id is rebuilt from the coordinates and alleles that are +# published alongside it, which is the same string the writer would have +# produced. +# @noRd +.prdVariantIds <- function(df, pos) { + ids <- if (is_in("ID", names(df))) as.character(df$ID) else NULL + if (!is.null(ids) && !any(is.na(parseVariantId(ids)$pos))) { + return(ids) + } + parts <- map(c("#chr", "REF", "ALT"), .prdCol, df = df) + if (any(map_lgl(parts, is.null)) || anyNA(pos)) { + abort(str_c( + "A published table must identify its variants: either an `ID` ", + "column of chrom:pos:ref:alt ids, or `#chr`, `start`/`end`, ", + "`REF` and `ALT` to build them from. An id without coordinates ", + "has no variant identity to store." + )) + } + formatVariantId( + as.character(parts[[1L]]), + pos, + as.character(parts[[2L]]), + as.character(parts[[3L]]) + ) +} + +# @noRd +.prdCol <- function(nm, df) { + if (is_in(nm, names(df))) df[[nm]] else NULL +} + +# `EZ` is the z the SOURCE supplied, and the spec means it that way: the z +# "provided if it was used to derive the ES and SE fields". So a published EZ +# restores `marginal_z_supplied = TRUE`, and its absence leaves z derived from +# ES / SE with the flag FALSE -- which is what keeps a re-export from +# publishing an EZ that pecotmr computed itself. +# @noRd +.prdMarginalZ <- function(df) { + n <- nrow(df) + ez <- .prdNumericOrNull(df, "EZ") + if (!is.null(ez) && any(!is.na(ez))) { + return(tibble( + marginal_z = ez, + marginal_z_supplied = !is.na(ez) + )) + } + es <- .prdNumericOrNull(df, "ES") + se <- .prdNumericOrNull(df, "SE") + if (is.null(es) || is.null(se)) { + return(tibble(.rows = n)) + } + tibble( + marginal_z = if_else(is.na(se) | se <= 0, NA_real_, es / se), + marginal_z_supplied = rep(FALSE, n) + ) +} + +# `LP` is -log10 p, which is the better published form (invertible, and no +# underflow at tiny p); the canonical table stores the p itself. +# @noRd +.prdMarginalP <- function(df) { + lp <- .prdNumericOrNull(df, "LP") + if (is.null(lp)) { + return(tibble(.rows = nrow(df))) + } + tibble(marginal_p = 10^(-lp)) +} + +# @noRd +.prdNumericOrNull <- function(df, nm) { + if (!is_in(nm, names(df))) { + return(NULL) + } + suppressWarnings(as.numeric(df[[nm]])) +} + +# The credible-set columns. Both formats publish an integer INDEX, because the +# label's prefix is the fitting method, which is already its own field. The +# canonical table stores the label, so it is rebuilt as `_`; +# NA stays NA, which is "in no credible set at this coverage". +# @noRd +.prdCsColumns <- function(df, method) { + csNames <- names(df)[str_detect(names(df), "^CS[0-9.]+$")] + if (length(csNames) == 0L) { + return(tibble(.rows = nrow(df))) + } + levels <- str_remove(csNames, "^CS") + cols <- c( + set_names( + map(csNames, .prdCsLabels, df = df, method = method), + str_c("cs_", levels) + ), + compact(set_names( + map(str_c("PUR", levels), .prdNumericOrNull, df = df), + str_c("cs_", levels, "_purity") + )) + ) + as_tibble(cols, .name_repair = "minimal") +} + +# @noRd +.prdCsLabels <- function(nm, df, method) { + idx <- suppressWarnings(as.integer(df[[nm]])) + prefix <- if (is.null(method) || is.na(method)) "cs" else method + if_else( + is.na(idx) | idx == 0L, + NA_character_, + str_c(prefix, "_", idx) + ) +} + +# Every published column the schema does not already account for, carried +# through under its own name: the per-credible-set `fullFit` statistics, and +# whatever a `columns = "all"` export or another tool added. +# +# Each is numeric when every non-NA value parses as a number, and character +# otherwise. Guessing per column rather than per value is what keeps an allele +# or label column from being coerced to NA, and the file itself carries no +# types to consult. +# @noRd +.prdPassthrough <- function(df) { + known <- c( + names(.PUB_RESTORE_VARIANT), + .PUB_NON_PAYLOAD, + "ES", + "SE", + "EZ", + "LP", + names(df)[str_detect(names(df), "^(CS|PUR)[0-9.]+$")] + ) + extra <- setdiff(names(df), known) + if (length(extra) == 0L) { + return(tibble(.rows = nrow(df))) + } + as_tibble( + set_names(map(extra, .prdAutoType, df = df), extra), + .name_repair = "minimal" + ) +} + +# @noRd +.prdAutoType <- function(nm, df) { + v <- as.character(df[[nm]]) + num <- suppressWarnings(as.numeric(v)) + if (all(is.na(num) == is.na(v))) num else v +} + +# Wakefield's approximate Bayes factor, as an OPT-IN substitute for a `LBF` +# the file does not carry. Opt-in because it is an approximation with a prior +# the caller has to choose: `priorVariance` is Wakefield's W, and the +# resulting log Bayes factors are not what susie's `lbf_variable` would have +# been. Colocalization's non-enloc path needs a real LBF matrix and says so +# rather than accepting this. +# @noRd +.prdWakefieldLbf <- function(out, priorVariance) { + if (is.null(priorVariance)) { + return(out) + } + assertNumber(priorVariance, lower = 0) + if (is_in("logBF", names(out)) && any(!is.na(out$logBF))) { + abort(str_c( + "`priorVariance` asks for Wakefield log Bayes factors, but this ", + "file already carries LBF. Drop `priorVariance` to keep the ", + "published values." + )) + } + z <- .prdCol("marginal_z", out) + se <- .prdCol("marginal_se", out) + absent <- c("z (EZ, or ES/SE)", "standard error (SE)")[ + c(is.null(z), is.null(se)) + ] + if (length(absent) > 0L) { + abort(glue( + "`priorVariance` asks for Wakefield log Bayes factors, which ", + "need a z and a standard error. This file publishes no ", + "{str_flatten(absent, ' and no ')}." + )) + } + mutate(out, logBF = .approxBayesFactor(z, se, W = priorVariance)$lbf) +} + +# ---- published table -> collection rows ------------------------------------- + +# One published table read into the long form both readers work from. +# @noRd +.prdRead <- function(path, region, format, sampleSelect, label) { + assertString(path) + if (.prdFormat(path, format) == "vcf") { + return(.prdVcfTable(path, region, 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()) +} + +# The row groups of a published table, in first-appearance order: one per +# (study, context, trait, method, block_id) tuple the file carries. A table +# with none of those axes is a single result, which is what a bare +# single-entry export writes. +# @noRd +.prdGroups <- function(df) { + # A header-only file -- which is what an export of an empty result writes + # -- has no groups at all, not one empty group: the identity axes are + # column names there, with no values to key anything by. + if (nrow(df) == 0L) { + return(list()) + } + cols <- intersect(.PRD_GROUP_COLS, names(df)) + if (length(cols) == 0L) { + return(list(seq_len(nrow(df)))) + } + key <- .pubIdentityKey(df, cols) + split(seq_len(nrow(df)), factor(key, levels = unique(key))) +} + +# The single value a per-ROW column takes over one group's variants. +# +# Several distinct values mean two different results were concatenated under +# one identity tuple, and picking either would silently publish one fit's +# window or provenance over another's -- so it is an error naming the column +# and what it held. +# @noRd +.prdGroupValue <- function(df, nm, idx, label) { + if (!is_in(nm, names(df))) { + return(NA_character_) + } + vals <- unique(as.character(df[[nm]][idx])) + vals <- vals[!is.na(vals)] + if (length(vals) == 0L) { + return(NA_character_) + } + if (length(vals) > 1L) { + abort(glue( + "{label}: `{nm}` takes {length(vals)} different values ", + "({str_flatten(vals, ', ')}) within one ", + "(study, context, trait, method) group. It is a per-result ", + "value, so two results were concatenated under one identity." + )) + } + vals[[1L]] +} + +# Reconcile what the file recorded with what the caller supplied. The +# argument FILLS IN a column the file does not carry -- which is the point of +# having it, for a file a user assembled themselves -- and a disagreement is +# an error rather than a silent override, because one of the two is wrong and +# the reader cannot tell which. +# `supplied` is never NULL here: both callers build it with `compact()`, so +# only the arguments the caller actually gave reach this function, and a +# NULL-guard would be dead by construction. +# @noRd +.prdResolve <- function(fileValue, supplied, nm, label) { + sup <- as.character(supplied)[[1L]] + if (!is.na(fileValue) && !identical(fileValue, sup)) { + abort(glue( + "{label}: `{nm}` was given as '{sup}' but the file records ", + "'{fileValue}'. Drop the argument to use the file's value." + )) + } + sup +} + +# The per-row identity and provenance of one group. +# @noRd +.prdRowFields <- function(df, idx, supplied, label) { + fromFile <- set_names( + map( + names(.PUB_RESTORE_IDENTITY), + .prdGroupValue, + df = df, + idx = idx, + label = label + ), + .PUB_RESTORE_IDENTITY + ) + for (nm in names(supplied)) { + fromFile[[nm]] <- .prdResolve( + fromFile[[nm]], + supplied[[nm]], + nm, + label + ) + } + fromFile +} + +# The analysis WINDOW of one group as a one-range GRanges, or NULL when the +# 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. +# @noRd +.prdRowRegion <- function(df, idx, label) { + start <- .prdGroupValue(df, "region_start", idx, label) + end <- .prdGroupValue(df, "region_end", idx, label) + chrom <- .prdRegionChrom(df, idx, label) + if (is.na(start) || is.na(end) || is.na(chrom)) { + return(NULL) + } + GenomicRanges::GRanges( + chrom, + IRanges::IRanges( + start = as.integer(start) + 1L, + end = as.integer(end) + ) + ) +} + +# The window's chromosome: from `region_id` when it has one (that is what the +# identifier encodes), else the variants' own, which cannot disagree with it +# because a result is fine-mapped within one block. +# @noRd +.prdRegionChrom <- function(df, idx, label) { + id <- .prdGroupValue(df, "region_id", idx, label) + if (!is.na(id) && str_detect(id, "_")) { + return(str_remove(id, "_[^_]*_[^_]*$")) + } + if (!is_in("#chr", names(df))) { + return(NA_character_) + } + chrom <- unique(as.character(df[["#chr"]][idx])) + if (length(chrom) == 1L) chrom else NA_character_ +} + +# Stack the per-group region ranges into the collections' `region` column: +# one range per row, or NULL when no row published one. A partial set would +# have to invent a window for the rest, so it is all or nothing. +# @noRd +.prdRegionColumn <- function(regions) { + if (any(map_lgl(regions, is.null))) { + return(NULL) + } + if (length(regions) == 0L) { + return(NULL) + } + # Through a GRangesList, not `c()`: `c()` on a list of S4 objects falls + # 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))) +} + +# A per-row character column for a constructor argument, or NULL when no row +# recorded it -- which is how the constructors are told to omit the column. +# @noRd +.prdRowColumn <- function(rows, nm) { + v <- map_chr(rows, .prdRowField, nm = nm) + if (all(is.na(v))) NULL else v +} + +# @noRd +.prdRowField <- function(r, nm) { + v <- r[[nm]] + if (is.null(v) || length(v) == 0L) NA_character_ else as.character(v)[[1L]] +} + +# The identity axes a class cannot be built without, checked once with every +# absent one named along with the argument that supplies it. The constructors +# reject NA on these axes, and a published file is free not to have recorded +# them -- a user who assembled the table themselves then says what they are. +# @noRd +.prdRequireIdentity <- function(rows, axes, label) { + absent <- keep(axes, .prdAxisAbsent, rows = rows) + if (length(absent) == 0L) { + return(invisible(NULL)) + } + args <- c( + study = "studyName", + context = "context", + trait = "trait", + method = "method" + ) + abort(glue( + "{label}: the file does not record {str_flatten(absent, ', ')}, ", + "which this result is keyed by. Pass ", + "{str_flatten(str_c('`', args[absent], '`'), ', ')} to supply ", + "{if (length(absent) == 1L) 'it' else 'them'}." + )) +} + +# @noRd +.prdAxisAbsent <- function(axis, rows) { + is.null(.prdRowColumn(rows, axis)) +} + +# `weight_standardized` describes the SCALE of the published 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 +# af-dependent amount at every variant and neither is recognisable on its own. +# So when a file publishes a weight without the flag, the caller has to say. +# @noRd +.prdRequireStandardized <- function(df, supplied, label) { + if (!is.null(supplied)) { + assertFlag(supplied) + return(invisible(NULL)) + } + if (!is_in("WGT", names(df)) || all(is.na(df$WGT))) { + return(invisible(NULL)) + } + if (is_in("weight_standardized", names(df))) { + if (any(!is.na(df$weight_standardized))) { + return(invisible(NULL)) + } + } + abort(glue( + "{label}: this file publishes WGT but not `weight_standardized`, ", + "and the scale cannot be recovered from the weights -- converting ", + "between them rescales every variant by a different, allele-", + "frequency-dependent factor. Pass `weightStandardized` to say ", + "whether the genotypes behind these weights were standardized." + )) +} + +# @noRd +.prdFlag <- function(v) { + if (is.null(v) || length(v) == 0L || is.na(v)) NA else as.logical(v) +} + +# ---- entry point: fine-mapping results -------------------------------------- + +#' @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. +#' +#' A merged table holding several \code{(study, context, trait, method)} +#' tuples reads back as a multi-row collection, one row per tuple. Which +#' class is returned follows the axes the file has: a result with a context +#' or a trait is a QTL result, one without is a GWAS result. +#' +#' @section What is required, and what is not: +#' Only what the class cannot exist without: variant ids that encode +#' coordinates (or the \code{#chr} / \code{start} / \code{end} / \code{REF} +#' / \code{ALT} columns to build them from) and a \code{PIP} column. +#' Everything else is optional, because each consumer needs a different few +#' columns -- Mendelian randomization the marginal effect and its standard +#' error, colocalization the log Bayes factors -- and a file converted from +#' another tool will have some and not others. A consumer reached without +#' what it needs says which column is missing. +#' +#' The fit itself is not published. A VCF's \code{##SAMPLE} header records +#' the two per-effect quantities that no per-variant column could hold -- +#' the prior variances \code{V} and the credible sets' \code{cs_index} -- +#' and those are restored as a partial \code{susieFit}; a BED carries +#' neither. Anything needing the posterior matrices (colocalization's LBF +#' path) wants the \code{LBF} columns, not the fit. +#' +#' @section What a round trip changes: +#' Every published quantity comes back identical, in either format. Three +#' things are not identities: +#' \itemize{ +#' \item \code{exportToBed()} 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. +#' \item Credible-set membership comes back as \code{NA} where the fit +#' recorded the \code{"_0"} not-captured sentinel. Both formats +#' publish an integer index, and \code{NA} is what every reader of the +#' column already treats as "in no credible set". +#' \item \code{data_source} and \code{weight_standardized} are +#' populated on the way back -- the writer derives the first and the +#' reader is told the second -- where a fit predating them left them +#' empty. +#' } +#' +#' @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. +#' @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. +#' @param studyName,context,trait,method Identity values for a file that did +#' not record them. Each FILLS IN the corresponding column when the file +#' lacks it; a value that disagrees with what the file does record is an +#' error rather than a silent override. +#' @param dataType Optional assay / modality label, same fill-in rule. +#' @param weightStandardized Whether the published posterior effect +#' (\code{WGT}) is on the standardized genotype scale. Required when the +#' file publishes \code{WGT} without \code{weight_standardized}: the scale +#' is not recoverable from the weights, since converting between the two +#' rescales every variant by its own allele-frequency-dependent factor. +#' @param sampleSelect For a multi-sample VCF, which samples to read. Each +#' sample is one fitted model. Defaults to all of them. +#' @param priorVariance Opt-in Wakefield prior variance (\code{W}) for +#' deriving per-variant log Bayes factors from z when the file has no +#' \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}}, +#' \code{\link{readTwasWeights}} +#' @examples +#' data(qtlFineMappingExample) +#' path <- file.path(tempdir(), "top_loci.bed") +#' exportToBed(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) +#' @importFrom purrr keep imap +#' @importFrom checkmate assertNumber +#' @export +readFineMappingResult <- function( + path, + region = NULL, + format = c("auto", "bed", "vcf"), + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + dataType = NULL, + weightStandardized = NULL, + sampleSelect = NULL, + priorVariance = NULL +) { + label <- "readFineMappingResult" + src <- .prdRead(path, region, format, sampleSelect, label) + df <- src$table + .prdRequirePip(df, label) + .prdRequireStandardized(df, weightStandardized, label) + supplied <- compact(list( + study = studyName, + context = context, + trait = trait, + method = method, + dataType = dataType, + standardized = weightStandardized + )) + groups <- .prdGroups(df) + rows <- imap( + groups, + .prdFmRow, + df = df, + supplied = supplied, + label = label, + priorVariance = priorVariance, + fits = src$fits + ) + .prdBuildFineMapping(rows, df, context, trait, label) +} + +# A fine-mapping result is a posterior, and the PIP is the posterior. A table +# without one is some other kind of file -- a weights export, most likely -- +# and building a result from it would produce rows whose every accessor is +# empty. +# @noRd +.prdRequirePip <- function(df, label) { + if (is_in("PIP", names(df))) { + return(invisible(NULL)) + } + abort(glue( + "{label}: no `PIP` column. A fine-mapping result is a posterior ", + "over variants, so the inclusion probability is the one statistic ", + "it cannot be read without. For a weights file use readTwasWeights()." + )) +} + +# One collection row from one group of published rows. +# @noRd +.prdFmRow <- function(idx, key, df, supplied, label, priorVariance, fits) { + fields <- .prdRowFields(df, idx, supplied, label) + tl <- .prdCanonical(slice(df, idx), fields$method, priorVariance) + list( + fields = fields, + region = .prdRowRegion(df, idx, label), + entry = fineMappingRow( + variantIds = tl$variant_id, + susieFit = .prdFitFor(fits, key), + topLoci = tl + ) + ) +} + +# The partial fit the VCF header recorded for this group, if any. A table with +# no identity axes is one unnamed group, so the key is an index rather than a +# key -- which must not be allowed to pick the first fit by position. +# @noRd +.prdFitFor <- function(fits, key) { + if (!is.character(key) || !is_in(key, names(fits))) { + return(NULL) + } + fits[[key]] +} + +# Which class the file describes, and build it. A QTL result is keyed by +# (study, context, trait, method) and a GWAS result by (study, method) plus +# its block, so the presence of a context or a trait is what separates them. +# An empty file has no values to look at, only its header, so there the +# COLUMN decides. +# @noRd +.prdBuildFineMapping <- function(rows, df, context, trait, label) { + regions <- .prdRegionColumn(map(rows, "region")) + fields <- map(rows, "fields") + if (length(rows) == 0L) { + return(.prdEmptyFineMapping(df, context, trait)) + } + if (.prdIsQtl(df, fields, context, trait)) { + return(.prdBuildQtl(rows, fields, regions, label)) + } + .prdRequireIdentity(fields, c("study", "method"), label) + GwasFineMappingResult( + studyName = .prdRowColumn(fields, "study"), + method = .prdRowColumn(fields, "method"), + entry = map(rows, "entry"), + blockId = .prdRowColumn(fields, "blockId"), + region = regions, + dataType = .prdRowColumn(fields, "dataType"), + dataSource = .prdRowColumn(fields, "dataSource"), + weightStandardized = .prdStandardizedColumn(fields) + ) +} + + +# A header-only file reads back as an EMPTY collection of the class its +# columns describe, rather than as an error about identity axes it has no +# rows to record. An empty export is a legitimate output -- a region where +# every entry was screened out still writes its schema. +# @noRd +.prdEmptyFineMapping <- function(df, context, trait) { + if (.prdIsQtl(df, list(), context, trait)) { + return(QtlFineMappingResult( + studyName = character(0), + context = character(0), + trait = character(0), + method = character(0), + entry = list() + )) + } + GwasFineMappingResult( + studyName = character(0), + method = character(0), + entry = list() + ) +} + +# @noRd +.prdBuildQtl <- function(rows, fields, regions, label) { + .prdRequireIdentity( + fields, + c("study", "context", "trait", "method"), + label + ) + QtlFineMappingResult( + studyName = .prdRowColumn(fields, "study"), + context = .prdRowColumn(fields, "context"), + trait = .prdRowColumn(fields, "trait"), + method = .prdRowColumn(fields, "method"), + entry = map(rows, "entry"), + jointStudies = .prdRowColumn(fields, "jointStudies"), + jointContexts = .prdRowColumn(fields, "jointContexts"), + jointTraits = .prdRowColumn(fields, "jointTraits"), + region = regions, + dataType = .prdRowColumn(fields, "dataType"), + dataSource = .prdRowColumn(fields, "dataSource"), + weightStandardized = .prdStandardizedColumn(fields) + ) +} + +# @noRd +.prdIsQtl <- function(df, fields, context, trait) { + if (!is.null(context) || !is.null(trait)) { + return(TRUE) + } + if (nrow(df) == 0L) { + return(any(is_in(c("context", "trait"), names(df)))) + } + !is.null(.prdRowColumn(fields, "context")) || + !is.null(.prdRowColumn(fields, "trait")) +} + +# @noRd +.prdStandardizedColumn <- function(fields) { + v <- .prdRowColumn(fields, "standardized") + if (is.null(v)) NULL else as.logical(v) +} + +# ---- entry point: TWAS weights ---------------------------------------------- + +#' @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. +#' +#' A merged table reads back as a multi-row collection, one row per +#' \code{(study, context, trait, method)} tuple. A fitted model whose +#' weights were a MATRIX -- a joint fit, one column per member -- was +#' published as one block per member with \code{trait} naming it, so it +#' reads back as one row per member with \code{joint_traits} keeping the +#' membership. The weights are identical either way; only the packing +#' differs. +#' +#' @section What is required, and what is not: +#' Variant ids that encode coordinates (or the columns to build them from) +#' and a \code{WGT} column -- a weight is the whole content of a +#' \code{TwasWeights}. The four identity axes must be recorded or supplied, +#' because the collection is keyed by them. Everything else is optional and +#' carried through if present. +#' +#' Cross-validation metrics are never published (they describe a model +#' scored on held-out folds, which is not per-variant and not +#' data-secure to express per sample), so a read-back collection has no +#' \code{cvResult} and no fitted models. +#' +#' @inheritParams readFineMappingResult +#' @param weightStandardized Whether the published weights are on the +#' 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}} +#' @examples +#' data(twasWeightsExample) +#' path <- file.path(tempdir(), "weights.bed") +#' exportToBed(twasWeightsExample, path) +#' readTwasWeights(path) + +#' @export +readTwasWeights <- function( + path, + region = NULL, + format = c("auto", "bed", "vcf"), + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + dataType = NULL, + weightStandardized = NULL, + sampleSelect = NULL +) { + label <- "readTwasWeights" + src <- .prdRead(path, region, format, sampleSelect, label) + df <- src$table + if (!is_in("WGT", names(df))) { + abort(glue( + "{label}: no `WGT` column. The weight is the whole content of a ", + "TwasWeights. For a fine-mapping table use ", + "readFineMappingResult()." + )) + } + .prdRequireStandardized(df, weightStandardized, label) + supplied <- compact(list( + study = studyName, + context = context, + trait = trait, + method = method, + dataType = dataType, + standardized = weightStandardized + )) + rows <- imap( + .prdGroups(df), + .prdTwRow, + df = df, + supplied = supplied, + label = label + ) + if (length(rows) == 0L) { + return(TwasWeights( + studyName = character(0), + context = character(0), + trait = character(0), + method = character(0), + entry = list() + )) + } + fields <- map(rows, "fields") + .prdRequireIdentity( + fields, + c("study", "context", "trait", "method"), + label + ) + TwasWeights( + studyName = .prdRowColumn(fields, "study"), + context = .prdRowColumn(fields, "context"), + trait = .prdRowColumn(fields, "trait"), + method = .prdRowColumn(fields, "method"), + entry = map(rows, "entry"), + jointStudies = .prdRowColumn(fields, "jointStudies"), + jointContexts = .prdRowColumn(fields, "jointContexts"), + jointTraits = .prdRowColumn(fields, "jointTraits"), + region = .prdRegionColumn(map(rows, "region")) + ) +} + +# One TwasWeightsRow from one group of published rows. +# +# The ids go through `.prdCanonical()` so they are derived exactly as the +# fine-mapping reader derives them. Variant-level columns BEYOND the weight +# are dropped: a TwasWeightsRow holds alleles and a weight, and the published +# `AF` came from the collection's LD panel, which is not in the file either. +# @noRd +.prdTwRow <- function(idx, key, df, supplied, label) { + fields <- .prdRowFields(df, idx, supplied, label) + sub <- slice(df, idx) + tl <- .prdCanonical(sub, fields$method, NULL) + list( + fields = fields, + region = .prdRowRegion(df, idx, label), + entry = twasWeightsRow( + variantIds = tl$variant_id, + weights = suppressWarnings(as.numeric(sub$WGT)), + weightStandardized = isTRUE(.prdFlag(fields$standardized)), + weightsDataType = .prdNaNull(fields$dataType) + ) + ) +} + +# @noRd +.prdNaNull <- function(v) { + if (is.null(v) || length(v) == 0L || is.na(v)) NULL else as.character(v) +} diff --git a/R/resultWriters.R b/R/resultWriters.R new file mode 100644 index 00000000..e8b5e6e0 --- /dev/null +++ b/R/resultWriters.R @@ -0,0 +1,2655 @@ +# ============================================================================= +# Published result writers +# ----------------------------------------------------------------------------- +# 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 +# FineMappingResult, TwasWeights. +# exportToBed(x, path, ...) the published long-format tables, one row per +# published observation, bgzipped + tabix-indexed +# on request. FineMappingResult, TwasWeights. +# +# One file because they are one problem -- project an S4 collection onto a +# FIXED published schema, join the posterior view to the marginal one, sort +# genomically, compress and index -- and while the VCF and the BED writers were +# separate each kept its own copy of the column pick, the row narrowing, the +# identity-key join and the fullFit column scan, which had already drifted +# apart. +# +# Five layers, in order: +# .pub* the shared layer: column pick, identity keys, row narrowing, the +# posterior/marginal join, genomic order, the table writer, +# output-path decoration +# .vcf* the VariantAnnotation-backed VCF / BCF writer +# .twv* the TWAS-weight VCF projection (weights as per-model samples) +# .fmb* the fine-mapping BED schemas (topLoci, fsusie) +# .twb* the TWAS-weight BED schemas (weights, performance) +# ============================================================================= + +#' @include AllGenerics.R AllClasses.R gwasSumStats.R twasWeights.R +#' @importFrom S4Vectors DataFrame SimpleList mcols +#' @importFrom GenomicRanges GRanges seqnames +#' @importFrom IRanges DataFrameList CharacterList +#' @importFrom Biostrings DNAStringSet DNAStringSetList +#' @importFrom Rsamtools asBcf bgzip indexTabix +#' @importFrom tools file_ext +#' @importFrom stringr str_sub +#' @importFrom purrr map map_chr keep set_names list_flatten +NULL + +# ---- shared: schema assembly ------------------------------------------------ + +# The identity axes a view is split on when several collection rows are folded +# into one published table. `blockId` is deliberately absent: the fSuSiE views +# do not carry it, and both sides of a join must key on the same axes. +# @noRd +.PUB_ROW_COLS <- c("study", "context", "trait", "method") + +# The identity axes a per-VARIANT join keys on -- the row identity plus the +# variant itself. +# @noRd +.PUB_VARIANT_COLS <- c( + "study", + "context", + "trait", + "blockId", + "method", + "variant_id" +) + +# Column `col` of `df`, or NA when the view does not carry it. Published +# schemas are fixed, so a column a particular input happens not to have becomes +# an NA cell rather than a missing column. `n` makes that NA a full-length +# vector, which the VCF FORMAT matrices need; the BED writers let the table +# recycle a scalar instead. +# @noRd +.pubCol <- function(df, col, n = NULL) { + if (!is.null(df) && is_in(col, names(df))) { + return(df[[col]]) + } + if (is.null(n)) NA else rep(NA, n) +} + +# The row-identity key a published view joins on: the identity columns the +# frame actually carries, "\r"-joined. A bare single-entry view carries none of +# them, so the key degenerates to whatever is present (the variant alone), +# which is exactly the right join for one entry. +# @noRd +.pubIdentityKey <- function(df, cols) { + present <- intersect(cols, names(df)) + if (length(present) == 0L) { + return(rep("", nrow(df))) + } + exec(str_c, !!!map(as.list(df[present]), .pubKeyPart), sep = "\r") +} + +# The same key read off a COLLECTION's tuple columns, so a long-format view's +# rows can be matched back to the collection row they came from. +# `.tupleColumn()` not `[[`: on a RangedTupleList `[[` extracts an ELEMENT, +# while the identity axes live in mcols. +# @noRd +.pubCollectionKey <- function(x, cols) { + present <- intersect(cols, .tupleColumnNames(x)) + exec( + str_c, + !!!map(map(present, .pubTupleColumn, x = x), .pubKeyPart), + sep = "\r" + ) +} + +# @noRd +.pubTupleColumn <- function(nm, x) as.character(.tupleColumn(x, nm)) + +# One component of an identity key. str_c() propagates NA, so a single absent +# axis (a GWAS result has no trait) would make the WHOLE key NA, losing the +# axes that ARE set -- and match() pairs NA with NA, so two unrelated rows +# would silently join. Spelling the absent value keeps NA matching NA within a +# column, which is what an absent axis means, without erasing the rest. +# @noRd +.pubKeyPart <- function(v) { + chr <- as.character(v) + if_else(is.na(chr), "", chr) +} + +# "chr22_10000000_18000000" -- the region_ID publication tables key on. +# @noRd +.pubRegionIds <- function(gr) { + if (!methods::is(gr, "GRanges") || length(gr) == 0L) { + return(character(0)) + } + str_c(as.character(seqnames(gr)), start(gr), end(gr), sep = "_") +} + +# A vector packed into one cell -- the published spelling for a column holding +# a curve, a grid or a set of names. +# @noRd +.pubPack <- function(z) str_flatten(as.character(z), collapse = ";") + +# The per-CS variant-level columns a fullFit topLoci build adds: the +# `within_cs_pip` scalar plus the wide within_cs_pip_ / cs_logbf_ / +# cs_effect_ sets. Data-driven in both the VCF and the BED writer, so the +# pattern lives once. +# @noRd +.pubFullFitColumns <- function(df) { + names(df)[str_detect(names(df), "^(within_cs_pip|cs_logbf_|cs_effect_)")] +} + +# Align a marginalEffects view to a posterior (topLoci) view, row for row, so +# the two can be read as one table. Both sides are keyed on (row identity, +# variant): across a whole collection that keeps two rows contributing the same +# variant apart, and for a single entry -- whose views carry no identity +# columns -- it degenerates to a variant_id join. +# +# `[` rather than slice(): a posterior variant with no marginal record must +# produce an NA row, and slice() rejects the NA index that expresses it. +# @noRd +.pubJoinMarginals <- function(base, marginals) { + idx <- match( + .pubIdentityKey(base, .PUB_VARIANT_COLS), + .pubIdentityKey(marginals, .PUB_VARIANT_COLS) + ) + marginals[idx, , drop = FALSE] +} + +# Fold a list of collections into one, choosing the class's own combiner. The +# `list` methods exist so a genome's worth of per-region RDSes can be exported +# in one call -- the combiners also handle the single-element case, so there is +# no separate concatenate-and-sort step. +# @noRd +.pubCombineList <- function(x) { + if (length(x) == 0L) { + abort("`x` must contain at least one result to export.") + } + if (methods::is(x[[1L]], "TwasWeights")) { + return(combineTwasWeights(x)) + } + if (methods::is(x[[1L]], "FineMappingResultBase")) { + return(combineFineMappingResults(x)) + } + abort(glue( + "`x` must be a TwasWeights or FineMappingResult object, or a list ", + "of one of those; got a list of {class(x[[1L]])[[1L]]}." + )) +} + +# Row indices whose identity axes equal every supplied selector. Axes the +# collection does not carry are ignored, so one call addresses a GWAS result +# (no context, no trait) and a QTL one alike. +# @noRd +.pubMatchingRows <- function(x, studyName, context, trait, method) { + cols <- .tupleColumnNames(x) + selectors <- compact(list( + study = studyName, + context = if (is_in("context", cols)) context, + trait = if (is_in("trait", cols)) trait, + method = method + )) + reduce( + names(selectors), + .pubNarrowRows, + x = x, + selectors = selectors, + .init = seq_len(nrow(x)) + ) +} + +# Narrow a row-index vector to those rows whose `axis` column equals the +# caller's requested value. `.tupleColumn()` not `[[`: on a RangedTupleList +# `[[` extracts an ELEMENT, while the identity axes live in mcols. +# @noRd +.pubNarrowRows <- function(rows, axis, x, selectors) { + rows[as.character(.tupleColumn(x, axis))[rows] == selectors[[axis]]] +} + +# Which of a source view's OWN columns to append after the published schema. +# The published columns always lead -- that is what makes the format +# publishable -- so this only ever ADDS: NULL adds nothing, "all" adds every +# column the view carries that the schema did not already map, and a character +# vector adds exactly those. +# +# `mapped` names the source columns the schema already publishes (under their +# published spellings) plus the GRanges range columns, which duplicate the +# position columns. Without that, "all" would write the same value twice under +# two names, and an explicitly named one would collide outright. +# @noRd +.pubViewColumns <- function(view, columns, mapped) { + if (is.null(columns)) { + return(character(0)) + } + available <- setdiff(names(view), mapped) + if (identical(columns, "all")) { + return(available) + } + assertCharacter(columns, any.missing = FALSE, .var.name = "columns") + .pubCheckViewColumns(columns, view, available, mapped) + columns +} + +# @noRd +.pubCheckViewColumns <- function(columns, view, available, mapped) { + clash <- intersect(columns, mapped) + if (length(clash) > 0L) { + abort(glue( + "`columns` names {str_flatten(clash, ', ')}, which the published ", + "schema already writes; drop them." + )) + } + unknown <- setdiff(columns, names(view)) + if (length(unknown) > 0L) { + abort(glue( + "`columns` names {str_flatten(unknown, ', ')}, which this view ", + "does not carry. Available: {str_flatten(available, ', ')}." + )) + } + invisible(NULL) +} + +# Refuse to export a collection whose rows lack a FULL-DATA fit. +# +# Cross-validation alone is not publishable. A CV-only run -- which is what +# `twasWeightsPipeline(fitFullData = FALSE)` produces, and which is legal only +# WITH cross-validation -- stores each row as an empty element with no weights +# and nothing but its `cvResult`. All it holds is fold-level results, and those +# cannot go in a published file: fold membership is sample-level information +# and sample names can be protected. So an export needs the full-data fit, and +# its absence is an ERROR rather than a silently empty output file. +# +# The check is on the OBJECT, not on the flag: `fitFullData` is a pipeline +# argument that may not have been the thing that emptied a row, and an export +# has to be safe whatever produced its input. +# +# It also keeps genomicRegion() honest. That derives a row's analysis window +# from range(x) when no `region` column was recorded, and a variant-less row +# contributes no range -- so the derived vector would be SHORTER than the +# collection and indexing it by row number would read a neighbour's window. +# @noRd +.pubRequireFullFit <- function(x, incomplete, what) { + if (length(incomplete) == 0L) { + return(invisible(x)) + } + abort(glue( + "{what}: {length(incomplete)} of {nrow(x)} row(s) carry no ", + "full-data fit, only cross-validation results -- ", + "{str_flatten(.pubRowLabels(x, incomplete), ', ')}. Fold-level ", + "results cannot be published (fold membership is sample-level ", + "information), so refit with `fitFullData = TRUE` and export that. ", + "The cross-validation record stays available through cvResult()." + )) +} + +# 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 +# when `weights` is NULL). +# @noRd +.twbIncompleteRows <- function(x) { + which( + lengths(x) == 0L | !map_lgl(seq_len(nrow(x)), .twbRowHasWeights, x = x) + ) +} + +# @noRd +.twbRowHasWeights <- function(i, x) !is.null(mcols(x[[i]])$weight) + +# Rows of a FineMappingResult with no fitted variants. Fine-mapping has no +# CV-only mode today -- .fmAttachCv() rebuilds the row around its existing +# susieFit and topLoci, so CV is strictly additive -- but the export checks +# rather than assumes it. +# @noRd +.fmbIncompleteRows <- function(x) { + which(lengths(x) == 0L) +} + +# Identity labels for the named rows, for an error message. +# @noRd +.pubRowLabels <- function(x, rows) { + keys <- .pubCollectionKey(x, .PUB_ROW_COLS) + str_replace_all(keys[rows], "\r", "|") +} + +# ---- shared: genomic order -------------------------------------------------- + +#' Order rows by genomic position, with chromosomes sorted naturally +#' +#' Returns the permutation that puts rows in genomic order: chromosomes +#' 1..22 numerically, then the non-numeric contigs (X, Y, MT, ...) +#' alphabetically after all of them, and positions numerically within a +#' chromosome. A plain character sort puts chr10 before chr2, which is why +#' published tables need this. +#' +#' Shared by every pecotmr writer and by the pipeline wrappers that merge +#' per-region tables, so one definition of "genomic order" covers both. +#' +#' @param chrom Chromosome labels. A leading \code{"chr"} is optional and is +#' ignored for ordering, so \code{"chr2"} and \code{"2"} sort alike. +#' @param start Start positions; coerced to numeric, non-numeric entries sort +#' last within their chromosome. +#' @param end Optional second position key, used only to break ties on +#' \code{start} (a half-open BED's end column). Ignored when it is not +#' numeric, so a table whose third column is not a position (an allele, say) +#' can pass it harmlessly. +#' @return An integer permutation, as from \code{order()}. +#' @examples +#' genomicOrder(c("chr10", "chr2", "chrX", "chr2"), c(5, 90, 1, 10)) +#' @export +genomicOrder <- function(chrom, start, end = NULL) { + rank <- .chromRank(chrom) + pos <- suppressWarnings(as.numeric(start)) + tie <- suppressWarnings(as.numeric(end)) + if (is.null(end) || all(is.na(tie))) { + return(order(rank, as.character(chrom), pos)) + } + order(rank, as.character(chrom), pos, tie) +} + +# The sort key behind genomicOrder(): numeric contigs keep their number, the +# rest sort alphabetically among themselves after every numeric one. A key for +# ONE vector, not a global scale -- the non-numeric contigs are ranked among +# themselves, so values are comparable only within a single call (which is all +# order() needs). +# @noRd +.chromRank <- function(chrom) { + bare <- str_remove(as.character(chrom), "^chr") + num <- suppressWarnings(as.numeric(bare)) + alpha <- sort(unique(bare[is.na(num)])) + if_else(is.na(num), 1000 + match(bare, alpha), num) +} + +# ---- shared: the table writer ----------------------------------------------- + +# Append caller-supplied trailing columns. Publication tables sometimes carry +# a field no S4 object can know -- the legacy top-loci BED's `block_id` is +# parsed from the RDS FILENAME -- so the writer takes them rather than forcing +# the caller to re-open and rewrite the file it just produced. +# @noRd +.pubAppendExtra <- function(out, extraColumns) { + if (is.null(extraColumns) || length(extraColumns) == 0L) { + return(out) + } + if (!is.list(extraColumns) || !is_named(extraColumns)) { + abort("`extraColumns` must be a NAMED list of columns.") + } + clash <- intersect(names(extraColumns), names(out)) + if (length(clash) > 0L) { + abort(glue( + "`extraColumns` would overwrite the published column(s) ", + "{str_flatten(clash, ', ')}; rename them." + )) + } + reduce( + names(extraColumns), + .pubAppendOneExtra, + extra = extraColumns, + .init = out + ) +} + +# @noRd +.pubAppendOneExtra <- function(out, nm, extra) { + v <- extra[[nm]] + if (!is_in(length(v), c(1L, nrow(out)))) { + abort(glue( + "`extraColumns${nm}` has length {length(v)}; it must be 1 ", + "(recycled) or {nrow(out)} (one value per row)." + )) + } + out[[nm]] <- if (nrow(out) == 0L) v[0L] else v + out +} + +# Write a table as a published BED: plain when `path` has no .gz/.bgz +# extension, bgzipped + tabix-indexed when it has. Rsamtools rather than a +# shell bgzip/tabix, so no pipeline needs an htslib binary on PATH. +# +# The builders already order their columns to the schema, so this takes the +# frame as given; it supplies the header for an empty result and drops the +# columns that had nothing to say. +# +# utils::write.table(), not vroom_write(): the two differ in how they format a +# float (1e-06 vs 1e-6) and in how many digits they keep. +# @noRd +# `emptySchema` is the header an empty result still documents -- the schema of +# whichever table was being written, since the fsusie table's vocabulary is not +# the per-variant one. +.pubWriteTable <- function( + out, + path, + naString, + index, + emptySchema = .pubSchema(character(0)), + keepColumns = character(0), + extraColumns = NULL +) { + if (is.null(out) || nrow(out) == 0L) { + # A header-only file documents the whole vocabulary rather than + # collapsing to the required core, which is what dropping empty + # columns would do when every column is vacuously absent. + out <- as_tibble( + set_names( + rep(list(character()), length(emptySchema)), + emptySchema + ), + .name_repair = "minimal" + ) + } else { + out <- .pubDropEmpty(out, keepColumns) + } + out <- .pubAppendExtra(out, extraColumns) + if (nrow(out) > 0L) { + out <- slice(out, genomicOrder(out[["#chr"]], out[["start"]])) + } + .pubEmitTable(out, path, naString, index) +} + +# Materialise the ordered table at `path`, compressing and indexing it when the +# extension asks for it. +# @noRd +.pubEmitTable <- function(out, path, naString, index) { + dir.create(dirname(path), showWarnings = FALSE, recursive = TRUE) + compress <- str_detect(path, "\\.(gz|bgz)$") + plain <- if (compress) str_remove(path, "\\.(gz|bgz)$") else path + utils::write.table( + out, + plain, + sep = "\t", + quote = FALSE, + row.names = FALSE, + na = naString + ) + if (!compress) { + return(invisible(path)) + } + bgzip(plain, dest = path, overwrite = TRUE) + file.remove(plain) + # An empty table has no records to index, and indexTabix() errors on one. + if (index && nrow(out) > 0L) { + indexTabix(path, format = "bed") + } + invisible(path) +} + +# ---- 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" +# @noRd +.decorateOutputPath <- function( + outputPath, + spec, + splitByContext, + splitByTrait +) { + if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { + return(outputPath) + } + ext <- str_to_lower(tools::file_ext(outputPath)) + composite <- ext == "bgz" || ext == "gz" + base <- if (composite) { + str_remove( + outputPath, + regex("\\.[^.]+\\.(bgz|gz)$", ignore_case = TRUE) + ) + } else { + tools::file_path_sans_ext(outputPath) + } + ext_keep <- str_sub( + outputPath, + str_length(base) + 1L, + str_length(outputPath) + ) + tags <- c( + if (isTRUE(splitByContext)) .pubPathTag(spec$context), + if (isTRUE(splitByTrait)) .pubPathTag(spec$trait) + ) + if (length(tags) == 0L) { + return(outputPath) + } + str_c(base, ".", str_flatten(tags, "."), ext_keep) +} + +# One path tag, or NULL when the axis carries no usable value (a context-less +# result split by context keeps its undecorated path). +# @noRd +.pubPathTag <- function(v) { + if (is.null(v) || is.na(v) || str_length(v) == 0L) { + return(NULL) + } + v +} + +# ---- VCF: entry points ------------------------------------------------------ + +#' @rdname exportToVcf +#' @export +setMethod( + "exportToVcf", + signature("list"), + function(x, outputPath, sampleName = NULL, ...) { + exportToVcf( + .pubCombineList(x), + outputPath, + sampleName = sampleName, + ... + ) + } +) + +#' @rdname exportToVcf +#' @export +setMethod( + "exportToVcf", + signature("GwasSumStats"), + function(x, outputPath, sampleName = NULL, studyName = NULL) { + .vcfRequireVariantAnnotation() + studyName <- .vcfResolveStudy(x, studyName) + ss <- sumStats(x, studyName = studyName) + mc <- mcols(ss) + .writeVcfImpl( + chrom = as.character(seqnames(ss)), + pos = start(ss), + ref = mc$A2, + alt = mc$A1, + snpIds = mc$SNP, + geno = .vcfSumstatsGeno(mc, length(ss)), + genoHeader = .vcfSumstatsGenoHeader(), + sampleName = sampleName %||% studyName, + outputPath = outputPath + ) + } +) + +# VariantAnnotation is a Suggests, and every VCF path needs it. +# @noRd +.vcfRequireVariantAnnotation <- function() { + if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { + abort("Package 'VariantAnnotation' is required for exportToVcf") + } + invisible(NULL) +} + +# Select which study to write (a GwasSumStats can hold many); a single-study +# collection defaults to its one study. +# @noRd +.vcfResolveStudy <- function(x, studyName) { + if (!is.null(studyName)) { + return(studyName) + } + if (nrow(x) != 1L) { + msg <- glue( + "This GwasSumStats has {nrow(x)} studies. ", + "Pass `study = ` to select one." + ) + abort(msg) + } + as.character(x$study[[1L]]) +} + +# Per-sample geno matrices for the GWAS-VCF fields the mcols can fill. +# +# Three released bugs are fixed here, all of them the same mistake -- a +# reserved key carrying the wrong quantity: +# * ES held the Z-SCORE. The spec defines ES as "effect size estimate +# relative to the alternative allele", and defines EZ for a z "provided if +# it was used to derive the ES and SE fields" -- which is exactly our case. +# * SS is not a GWAS-VCF key at all. The spec's sample-size field is NS. +# * AF held MAF. The spec's AF is the ALTERNATIVE allele frequency, and a +# minor-allele frequency cannot be converted to one -- it has lost which +# allele it refers to -- so it goes under our own MAF key instead of being +# mislabelled. +# @noRd +.vcfSumstatsGeno <- function(mc, nSnps) { + compact(list( + ES = .vcfSumstatsField(mc, "BETA", nSnps), + SE = .vcfSumstatsField(mc, "SE", nSnps), + EZ = .vcfSuppliedZ(mc, nSnps), + NS = .vcfSumstatsField(mc, "N", nSnps, as.integer), + AF = .vcfSumstatsField(mc, "AF", nSnps), + MAF = .vcfSumstatsField(mc, "MAF", nSnps) + )) +} + +# `EZ` only where the SOURCE supplied the z. The spec defines the field as the +# z "provided if it was used to derive the ES and SE fields", so publishing a +# Wald z that pecotmr computed from a recorded beta/se inverts its meaning -- +# a reader would then believe ES and SE were derived from it. The loaders +# record `z_supplied` for exactly this; a collection built by hand without it +# is treated as not having supplied one, which is the safe direction. +# @noRd +.vcfSuppliedZ <- function(mc, nSnps) { + z <- .vcfSumstatsField(mc, "Z", nSnps) + if (is.null(z)) { + return(NULL) + } + supplied <- as.logical(.pubCol(mc, "z_supplied", nSnps)) + if (!any(isTRUE(supplied) | (!is.na(supplied) & supplied))) { + return(NULL) + } + matrix(replace(as.numeric(z), !supplied | is.na(supplied), NA_real_), nSnps) +} + +# @noRd +.vcfSumstatsField <- function(mc, nm, nSnps, coerce = as.numeric) { + if (!is_in(nm, colnames(mc))) { + return(NULL) + } + matrix(coerce(mc[[nm]]), nSnps) +} + +# The FORMAT header for the sumstats geno fields, with the spec's own wording +# for the keys it defines. +# @noRd +.vcfSumstatsGenoHeader <- function() { + DataFrame( + Number = rep("A", 6L), + Type = c("Float", "Float", "Float", "Integer", "Float", "Float"), + Description = c( + "Effect size estimate relative to the alternative allele", + "Standard error of effect size estimate", + str_c( + "Z-score provided if it was used to derive the ES and SE ", + "fields" + ), + str_c( + "Variant-specific number of samples/individuals with called ", + "genotypes used to test association with specified trait" + ), + "Alternative allele frequency in trait subset", + "Minor allele frequency (not the spec's AF: allele unknown)" + ), + row.names = c("ES", "SE", "EZ", "NS", "AF", "MAF") + ) +} + +#' @rdname exportToVcf +#' @export +setMethod( + "exportToVcf", + signature("FineMappingResultBase"), + function( + x, + outputPath, + sampleName = NULL, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + splitByContext = FALSE, + splitByTrait = FALSE + ) { + .vcfRequireVariantAnnotation() + # 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. + groups <- .resolveFineMappingGroups( + x, + outputPath = outputPath, + studyName = studyName, + context = context, + trait = trait, + method = method, + splitByContext = splitByContext, + splitByTrait = splitByTrait + ) + invisible(map_chr( + groups, + .fmvWriteGroup, + x = x, + sampleName = sampleName + )) + } +) + +# 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. +# @noRd +.resolveFineMappingGroups <- function( + x, + outputPath, + studyName, + context, + trait, + method, + splitByContext, + splitByTrait +) { + rows <- .pubMatchingRows(x, studyName, context, trait, method) + if (length(rows) == 0L) { + abort("exportToVcf: no rows match the supplied selectors.") + } + specs <- map(rows, .rowSpec, x = x) + if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { + return(list(list(path = outputPath, specs = specs))) + } + map( + specs, + .fmvSplitGroup, + outputPath = outputPath, + splitByContext = splitByContext, + splitByTrait = splitByTrait + ) +} + +# @noRd +.fmvSplitGroup <- function(spec, outputPath, splitByContext, splitByTrait) { + list( + path = .decorateOutputPath( + outputPath, + spec, + splitByContext, + splitByTrait + ), + specs = list(spec) + ) +} + +# Build a (study, context, trait, method) spec list for one row index. +# @noRd +.rowSpec <- function(r, x) { + 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] + ) +} + +# ---- VCF: FORMAT field specs ------------------------------------------------ + +# One VCF FORMAT field spec: name, per-variant `values`, VCF `type` +# (Float/Integer), and header `desc`. Number is always "A" (per-allele). +# @noRd +.vcfSpec <- function(name, values, type, desc) { + list(name = name, values = values, type = type, desc = desc) +} + +# The per-variant FORMAT fields, named exactly as the BED columns are: the +# spec's keys for the quantities it defines, ours alongside them for the rest. +# +# `ES` is the MARGINAL effect and nothing else. It used to hold the posterior +# conditional effect when the fit reported one and the marginal beta otherwise, +# so a consumer could not tell which quantity it had. The posterior effect now +# has its own field -- `WGT`, which is also the prediction weight, because a +# susie posterior mean IS the TWAS coefficient. +# @noRd +.vcfCoreSpecs <- function(base, m, nSnps) { + p <- suppressWarnings(as.numeric(.pubCol(m, "p", nSnps))) + list( + .vcfSpec( + "ES", + .pubCol(m, "beta", nSnps), + "Float", + "Effect size estimate relative to the alternative allele" + ), + .vcfSpec( + "SE", + .pubCol(m, "se", nSnps), + "Float", + "Standard error of effect size estimate" + ), + .vcfSpec( + "EZ", + .pubEz(m, nSnps), + "Float", + str_c( + "Z-score provided if it was used to derive the ES and SE ", + "fields" + ) + ), + .vcfSpec( + "LP", + if_else(is.na(p) | p <= 0, NA_real_, -log10(p)), + "Float", + "-log10 p-value for effect estimate" + ), + .vcfSpec( + "NS", + as.integer(.pubCol(m, "N", nSnps)), + "Integer", + str_c( + "Variant-specific number of samples/individuals with called ", + "genotypes used to test association with specified trait" + ) + ), + .vcfSpec( + "AF", + .pubCol(base, "af", nSnps), + "Float", + "Alternative allele frequency in trait subset" + ), + .vcfSpec( + "WGT", + .pubCol(base, "posterior_effect", nSnps), + "Float", + "Posterior effect estimate, i.e. the prediction weight" + ), + .vcfSpec( + "WGTSE", + .pubCol(base, "posterior_se", nSnps), + "Float", + "Standard error of the posterior effect estimate" + ) + ) +} + +# Credible-set FORMAT fields. pecotmr emits CS (+ PUR when +# a purity column exists) for EVERY cs_ column present, so coverage +# levels are data-driven rather than the 50/70/95 xqtl-protocol default. +# @noRd +.vcfCsSpecs <- function(base) { + csCols <- names(base)[str_detect(names(base), "^cs_[0-9.]+$")] + perCol <- map(csCols, .vcfCsColSpecs, base = base) + list_flatten(perCol) +} + +# Per-CS variant-level fullFit FORMAT fields (within_cs_pip scalar plus the +# wide within_cs_pip_ / cs_logbf_ / cs_effect_ sets emitted when +# the topLoci was built with fullFit = TRUE). Each column becomes an uppercase +# field. +# @noRd +.vcfFullFitSpecs <- function(base) { + map(.pubFullFitColumns(base), .vcfFullFitColSpec, base = base) +} + +# Posterior FORMAT fields, only when a fine-mapping posterior table exists: +# PIP, per-variant log Bayes factor, local false sign rate, plus the dynamic +# credible-set and fullFit column sets. +# @noRd +.vcfPosteriorSpecs <- function(base, nSnps) { + fixed <- list( + .vcfSpec( + "PIP", + .pubCol(base, "pip", nSnps), + "Float", + "Posterior inclusion probability" + ), + .vcfSpec( + "LBF", + .pubCol(base, "logBF", nSnps), + "Float", + "Per-variant log Bayes factor (max single effect)" + ), + .vcfSpec( + "LFSR", + .pubCol(base, "lfsr", nSnps), + "Float", + "Local false sign rate (per-condition posterior)" + ) + ) + c(fixed, .vcfCsSpecs(base), .vcfFullFitSpecs(base)) +} + +# FORMAT specs for one cs_ column: a CS index field plus a PUR purity +# field when a matching *_purity column exists. +# @noRd +.vcfCsColSpecs <- function(cc, base) { + cov <- str_remove(cc, "^cs_") + csSpec <- .vcfSpec( + str_c("CS", cov), + .pubCsIndex(base[[cc]]), + "Integer", + glue("Credible-set index at {cov}% coverage") + ) + pc <- str_c(cc, "_purity") + if (!is_in(pc, names(base))) { + return(list(csSpec)) + } + pur <- suppressWarnings(as.numeric(base[[pc]])) + purSpec <- .vcfSpec( + str_c("PUR", cov), + pur, + "Float", + glue("Purity (min abs corr) of the {cov}% credible set") + ) + list(csSpec, purSpec) +} + +# The FORMAT spec for one fullFit posterior column (uppercased Float field). +# @noRd +.vcfFullFitColSpec <- function(cc, base) { + v <- suppressWarnings(as.numeric(base[[cc]])) + .vcfSpec( + str_to_upper(cc), + v, + "Float", + glue("Per-credible-set variant statistic ({cc})") + ) +} + +# TRUE when a FORMAT spec has at least one non-NA value (drop all-NA specs). +# @noRd +.vcfSpecHasValues <- function(s) { + any(!is.na(s$values)) +} + +# ---- VCF: fine-mapping assembly --------------------------------------------- + +# Resolve the per-variant body: the fine-mapping POSTERIOR (topLoci at +# signalCutoff 0 = every fitted variant, carrying pip / CS membership / +# conditional effect) joined to the MARGINAL univariate sumstats +# (marginalEffects) where those exist. mvSuSiE / fSuSiE have no marginal +# sumstats, so the posterior drives the variant set; univariate susie adds +# marginal ES=beta / SE / LP / AF on top. Returns list(base, m, hasPost). +# @noRd +.vcfResolveBody <- function(entry, sn) { + post <- try_fetch( + as_tibble(as.data.frame( + S4Vectors::mcols(topLoci(entry, signalCutoff = 0)) + )), + error = function(cnd) NULL + ) + marg <- try_fetch( + as_tibble(marginalEffects(entry)), + error = function(cnd) NULL + ) + hasPost <- !is.null(post) && nrow(post) > 0L + hasMarg <- !is.null(marg) && nrow(marg) > 0L + if (hasPost) { + base <- post + m <- if (hasMarg) .pubJoinMarginals(base, marg) else NULL + } else if (hasMarg) { + base <- marg + m <- marg + } else { + msg <- glue("exportToVcf: entry [{sn}] has no variants to write") + abort(msg) + } + list(base = base, m = m, hasPost = hasPost) +} + +# The geno header DataFrame for a set of FORMAT specs. +# @noRd +.vcfGenoHeader <- function(specs) { + DataFrame( + Number = rep("A", length(specs)), + Type = map_chr(specs, "type"), + Description = map_chr(specs, "desc"), + row.names = map_chr(specs, "name") + ) +} + +# Sample names: the caller's, or the derived ones. A caller-supplied vector has +# to name EVERY sample -- the samples are what the file is keyed on, so a +# partial naming would silently mislabel the rest. +# @noRd +.vcfSampleNames <- function(derived, sampleName) { + if (is.null(sampleName)) { + return(derived) + } + if (length(sampleName) != length(derived)) { + abort(glue( + "`sampleName` has length {length(sampleName)} but ", + "{length(derived)} model(s) will be written; pass one name per ", + "model or NULL to derive them." + )) + } + as.character(sampleName) +} + +# Write one file's worth of fine-mapping fits: the records are the UNION of +# their variants, each fit is a sample, and a fit that did not include a +# variant leaves its cells empty. +# @noRd +.fmvWriteGroup <- function(group, x, sampleName) { + rows <- map(group$specs, .fmvRowSpecs, x = x) + sn <- .vcfSampleNames(map_chr(rows, "sampleName"), sampleName) + variants <- .fmvVariantUnion(rows) + specs <- keep( + .fmvFormatSpecs(rows, variants$variant_id), + .vcfSpecHasValues + ) + .writeVcfImpl( + chrom = variants$chrom, + pos = variants$pos, + ref = variants$A2, + alt = variants$A1, + snpIds = variants$variant_id, + geno = set_names(map(specs, "values"), map_chr(specs, "name")), + genoHeader = .vcfGenoHeader(specs), + sampleName = sn, + outputPath = group$path, + sampleMeta = .fmvSampleMeta(rows, sn) + ) + 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 + ) + sn <- .fmvSampleLabel(spec) + body <- .vcfResolveBody(entry, sn) + nSnps <- nrow(body$base) + list( + sampleName = sn, + spec = spec, + perFit = .pubPerFitFields(x, spec$row, susieFit(entry)), + base = body$base, + nVariants = nSnps, + variantIds = as.character(.pubCol(body$base, "variant_id", nSnps)), + formats = c( + .vcfCoreSpecs(body$base, body$m, nSnps), + if (body$hasPost) .vcfPosteriorSpecs(body$base, nSnps) else list() + ) + ) +} + +# @noRd +.fmvSampleLabel <- function(spec) { + as.character(glue( + "{spec$study}|{spec$context %||% '_'}|", + "{spec$trait %||% '_'}|{spec$method}" + )) +} + +# The union of every sample's variants, in genomic order, carrying the alleles +# the first fit to report each one recorded. +# @noRd +.fmvVariantUnion <- function(rows) { + tbl <- bind_rows(map(rows, .fmvRowVariants)) + tbl <- slice(tbl, which(!duplicated(tbl$variant_id))) + slice(tbl, genomicOrder(tbl$chrom, tbl$pos)) +} + +# @noRd +.fmvRowVariants <- function(r) { + n <- r$nVariants + tibble( + variant_id = r$variantIds, + chrom = as.character(.pubCol(r$base, "chrom", n)), + pos = .pubCol(r$base, "pos", n), + A1 = as.character(.pubCol(r$base, "A1", n)), + A2 = as.character(.pubCol(r$base, "A2", n)) + ) +} + +# The multi-sample FORMAT specs: one per field name ANY sample reported, its +# values a nVariant x nSample matrix placed onto the union by variant id. The +# field set is the union because which posterior fields a fit reports depends +# on the method, and one file needs one FORMAT schema across its samples. +# @noRd +.fmvFormatSpecs <- function(rows, unionIds) { + fields <- unique(list_c(c( + list(character(0)), + map(rows, .fmvRowFormatNames) + ))) + map(fields, .fmvFormatSpec, rows = rows, unionIds = unionIds) +} + +# @noRd +.fmvRowFormatNames <- function(r) map_chr(r$formats, "name") + +# @noRd +.fmvFormatSpec <- function(nm, rows, unionIds) { + template <- compact(map(rows, .fmvFindFormat, nm = nm))[[1L]] + cols <- map( + rows, + .fmvFormatColumn, + nm = nm, + unionIds = unionIds, + type = template$type + ) + .vcfSpec(nm, exec(cbind, !!!cols), template$type, template$desc) +} + +# @noRd +.fmvFindFormat <- function(r, nm) detect(r$formats, .fmvFormatNamed, nm = nm) + +# @noRd +.fmvFormatNamed <- function(f, nm) identical(f$name, nm) + +# One sample's column of a FORMAT field. The NA fill matches the field's +# declared VCF type, so an Integer field does not become a Float the moment one +# sample is missing a variant. +# @noRd +.fmvFormatColumn <- function(r, nm, unionIds, type) { + fill <- if (identical(type, "Integer")) NA_integer_ else NA_real_ + out <- rep(fill, length(unionIds)) + f <- .fmvFindFormat(r, nm) + if (is.null(f)) { + return(out) + } + out[match(r$variantIds, unionIds)] <- f$values + out +} + +# The ##SAMPLE header block for a fine-mapping VCF: each fit's identity tuple +# and how many variants it contributed, so the file says which fits it holds +# without reparsing the sample names. +# @noRd +.fmvSampleMeta <- function(rows, sampleNames) { + tbl <- bind_rows(map(rows, .fmvSampleMetaRow)) + .pubSampleMetaFrame(tbl, sampleNames) +} + +# The `##SAMPLE` key for each per-fit field. +# +# The DATA vocabulary is shared between the two formats, but a structured VCF +# header key cannot be: Rsamtools' header parser splits the `<...>` on +# `,(?=[[:alnum:]]+=)`, so a key containing an underscore is not recognised as +# a key at all -- it glues onto the previous field's value, and everything +# after it on the line is lost. Six of these fields were unreadable for that +# reason. CamelCase is also what the GWAS-VCF spec's own SAMPLE keys use +# (`TotalVariants`, `StudyType`), so this follows the format's convention +# rather than departing from ours. This table is the only place the two +# spellings meet, and `.prdVcfSampleMeta()` reads them back through it. +# @noRd +.PUB_SAMPLE_KEYS <- c( + total_variants = "TotalVariants", + study = "Study", + context = "Context", + trait = "Trait", + method = "Method", + block_id = "BlockId", + data_type = "DataType", + data_source = "DataSource", + weight_standardized = "WeightStandardized", + joint_studies = "JointStudies", + joint_contexts = "JointContexts", + joint_traits = "JointTraits", + region_id = "RegionId", + region_start = "RegionStart", + region_end = "RegionEnd", + V = "V", + cs_index = "CsIndex" +) + +# The ##SAMPLE block as a DataFrame, with the fields that are empty for EVERY +# sample dropped -- the same rule the BED columns follow, so a header is not +# padded with `BlockId=.,JointStudies=.,V=.` for an input that has none. +# @noRd +.pubSampleMetaFrame <- function(tbl, sampleNames) { + kept <- names(tbl)[!map_lgl(tbl, .pubAllAbsent)] + df <- as.data.frame(mutate( + select(tbl, all_of(kept)), + across(everything(), .vcfHeaderValue) + )) + names(df) <- .pubSampleKeys(names(df)) + `rownames<-`(as(df, "DataFrame"), .vcfHeaderValue(sampleNames)) +} + +# Field names as `##SAMPLE` keys. An unmapped name is a new per-fit field that +# has not been given a key: letting it through would write a line that reads +# back short by that field and every field after it, so it stops here. +# @noRd +.pubSampleKeys <- function(nms) { + absent <- nms[!is_in(nms, names(.PUB_SAMPLE_KEYS))] + if (length(absent) > 0L) { + abort(glue( + "Per-fit field(s) {str_flatten(absent, ', ')} have no ", + "##SAMPLE key. Add them to .PUB_SAMPLE_KEYS: an underscored key ", + "is silently unreadable." + )) + } + unname(.PUB_SAMPLE_KEYS[nms]) +} + +# @noRd +.fmvSampleMetaRow <- function(r) { + bind_cols( + tibble(total_variants = r$nVariants), + as_tibble(r$perFit) + ) +} + +# The per-fit fields a `##SAMPLE` line carries, named exactly as the BED's +# per-fit COLUMNS are -- one vocabulary across both formats. The header line +# spells them in CamelCase, because a VCF structured-header key must be +# alphanumeric to be parseable; `.PUB_SAMPLE_KEYS` is that one translation. +# +# `V` and `cs_index` are the reason this block is load-bearing rather than +# decoration: they are per-EFFECT, so no per-variant column can hold them, and +# 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) + inRange <- !is.null(row) && length(rg) >= row + md <- mcols(x) + list( + study = .pubRowValue(md, "study", row), + context = .pubRowValue(md, "context", row), + trait = .pubRowValue(md, "trait", row), + method = .pubRowValue(md, "method", row), + block_id = .pubRowValue(md, "blockId", row), + data_type = .pubRowValue(md, "dataType", row), + data_source = .pubDataSource(x), + joint_studies = .pubRowValue(md, "jointStudies", row), + joint_contexts = .pubRowValue(md, "jointContexts", row), + joint_traits = .pubRowValue(md, "jointTraits", row), + weight_standardized = .pubRowValue(md, "standardized", row), + 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_, + V = .pubPackOrNa(.fitField(fit, "V")), + cs_index = .pubPackOrNa(.fitField(fit, "sets", "cs_index")) + ) +} + +# @noRd +# One mcols cell as a string. `[[row]]` then pack, rather than +# as.character() on the column: several of these are List columns (a +# TwasWeights `dataType` is one) and as.character() on a CompressedList +# errors. +# @noRd +.pubRowValue <- function(md, nm, row) { + if (is.null(row) || !is_in(nm, colnames(md))) { + return(NA_character_) + } + cell <- md[[nm]][[row]] + if (length(cell) == 0L) NA_character_ else .pubPack(cell) +} + +# @noRd +.pubPackOrNa <- function(v) { + if (length(v) == 0L) NA_character_ else .pubPack(v) +} + +# ---- VCF: TWAS weights ------------------------------------------------------ + +#' @rdname exportToVcf +#' @export +setMethod( + "exportToVcf", + signature("TwasWeights"), + function( + x, + outputPath, + sampleName = NULL, + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL + ) { + .vcfRequireVariantAnnotation() + .pubRequireFullFit(x, .twbIncompleteRows(x), "exportToVcf") + rows <- .pubMatchingRows(x, studyName, context, trait, method) + if (length(rows) == 0L) { + abort("exportToVcf: 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 FineMappingResult 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")) + 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 ", + "FineMappingResult." + )) + } + .twvWriteSamples( + x, + .twvSampleSpecs(x, rows), + sampleName, + outputPath + ) + } +) + +# Project the selected models onto one GWAS-VCF-style file: the records are the +# UNION of their variants, each model is a sample, and a model that did not +# weight a variant leaves that cell empty. +# +# Multi-sample rather than one file per model because that is what GWAS-VCF +# does with several studies, and because a region's TwasWeights routinely holds +# a dozen methods for one gene -- a dozen near-identical files would be the +# wrong shape for the same information. +# @noRd +.twvWriteSamples <- function(x, samples, sampleName, outputPath) { + gr <- .twvVariantUnion(x, samples) + ids <- .grVariantIds(gr) + mc <- mcols(gr) + wgt <- .twvWeightMatrix(x, samples, ids) + meta <- .twbRowMetadata(x) + sn <- .twvSampleNames(samples, meta, sampleName) + .writeVcfImpl( + chrom = as.character(seqnames(gr)), + pos = start(gr), + ref = as.character(mc$A2), + alt = as.character(mc$A1), + snpIds = ids, + geno = list(WGT = wgt), + genoHeader = .twvGenoHeader(), + sampleName = sn, + outputPath = outputPath, + sampleMeta = .twvSampleMeta( + samples, + sn, + meta, + colSums(!is.na(wgt)), + x + ) + ) +} + +# The ##SAMPLE header block: what GWAS-VCF records per study, here per fitted +# MODEL -- its identity tuple, how many variants it actually weighted, and the +# scale its weights are on. +# +# Cross-validation metrics are deliberately NOT here. They describe how a model +# scored on held-out FOLDS, and a published file has no data-secure way to say +# anything fold-level: fold membership is sample-level information and sample +# names can be protected. The export carries the full-data fit and nothing +# else; callers who want the CV record read cvResult() and tabulate it +# themselves. +# @noRd +.twvSampleMeta <- function(samples, sampleNames, meta, nWeighted, x) { + tbl <- bind_rows(map( + seq_along(samples), + .twvSampleMetaRow, + samples = samples, + meta = meta, + nWeighted = nWeighted, + x = x + )) + .pubSampleMetaFrame(tbl, sampleNames) +} + +# @noRd +.twvSampleMetaRow <- function(j, samples, meta, nWeighted, x) { + s <- samples[[j]] + ident <- slice(meta, s$row) + fields <- .pubPerFitFields(x, s$row, NULL) + # A weight-matrix column is a member of a joint fit, so `trait` names the + # member while `joint_traits` keeps the membership. Assigned rather than + # bound, so there is one `trait` field and not a repaired duplicate. + fields$trait <- .twbTraitOf(s$label, ident$trait) + bind_cols(tibble(total_variants = nWeighted[[j]]), as_tibble(fields)) +} + +# One ##SAMPLE field value. These are written unquoted, so a comma, an equals +# sign, an angle bracket or whitespace would break the line's key=value +# structure; an absent value is spelled "." as elsewhere in VCF. +# @noRd +.vcfHeaderValue <- function(v) { + chr <- str_replace_all(as.character(v), "[,=<>[:space:]]+", "_") + if_else(is.na(chr), ".", chr) +} + +# @noRd +.twvGenoHeader <- function() { + DataFrame( + Number = "A", + Type = "Float", + Description = str_c( + "TWAS prediction weight for the effect (ALT) allele; empty where ", + "the model did not weight the variant" + ), + row.names = "WGT" + ) +} + +# One sample spec per (collection row, weight column): the row it reads, which +# weight column, and that column's label. A plain weight vector contributes one +# sample; a weight MATRIX (fSuSiE collapses a functional fit to variants x +# features) contributes one per column. +# @noRd +.twvSampleSpecs <- function(x, rows) { + list_flatten(map(rows, .twvRowSampleSpecs, x = x)) +} + +# @noRd +.twvRowSampleSpecs <- function(i, x) { + # .pubRequireFullFit() has already established that every row has weights. + labels <- .twbWeightLabels(mcols(x[[i]])$weight) + map(seq_along(labels), .twvOneSampleSpec, row = i, labels = labels) +} + +# @noRd +.twvOneSampleSpec <- function(k, row, labels) { + list(row = row, column = k, label = labels[[k]]) +} + +# The union of every selected model's variants, in genomic order. The weight +# mcols is dropped first: it is numeric on one row and a matrix on another, and +# c() on GRanges requires one mcols schema. +# @noRd +.twvVariantUnion <- function(x, samples) { + rows <- unique(map_int(samples, "row")) + all <- exec(c, !!!map(rows, .twvRowAlleles, x = x)) + gr <- all[!duplicated(.grVariantIds(all))] + gr[genomicOrder(as.character(seqnames(gr)), start(gr))] +} + +# @noRd +.twvRowAlleles <- function(i, x) { + gr <- x[[i]] + S4Vectors::`mcols<-`( + gr, + value = mcols(gr)[, c("A1", "A2"), drop = FALSE] + ) +} + +# The nVariant x nSample weight matrix: one column per model, placed onto the +# union by variant id. +# @noRd +.twvWeightMatrix <- function(x, samples, unionIds) { + exec( + cbind, + !!!map(samples, .twvSampleColumn, x = x, unionIds = unionIds) + ) +} + +# @noRd +.twvSampleColumn <- function(s, x, unionIds) { + gr <- x[[s$row]] + out <- rep(NA_real_, length(unionIds)) + out[match(.grVariantIds(gr), unionIds)] <- + .twbWeightColumn(s$column, mcols(gr)$weight) + out +} + +# Sample names: the caller's, or the model's identity tuple -- with the weight +# column's label appended when the row carries a weight matrix, since those +# columns are separate samples and must have separate names. +# @noRd +.twvSampleNames <- function(samples, meta, sampleName) { + .vcfSampleNames( + map_chr(samples, .twvSampleLabel, meta = meta), + sampleName + ) +} + +# @noRd +.twvSampleLabel <- function(s, meta) { + ident <- slice(meta, s$row) + tags <- c(ident$study, ident$context, ident$trait, ident$method) + if (!is.na(s$label)) { + tags <- c(tags, s$label) + } + str_flatten(if_else(is.na(tags), "_", tags), "|") +} + +# ---- VCF: the VariantAnnotation writer -------------------------------------- + +# Internal implementation shared by all methods. `sampleName` may name several +# samples, in which case every geno matrix is nVariant x nSample. +# `sampleMeta` is an optional per-sample DataFrame written as ##SAMPLE header +# lines (GWAS-VCF's per-study metadata block). +# @noRd +.writeVcfImpl <- function( + chrom, + pos, + ref, + alt, + snpIds, + geno, + genoHeader, + sampleName, + outputPath, + sampleMeta = NULL +) { + # Ensure chromosome names have the "chr" prefix. + if (!all(str_detect(chrom, "^chr"))) { + chrom <- str_c("chr", chrom) + } + gr <- .vcfBuildRanges(chrom, pos, ref, alt, snpIds) + hdr <- .vcfBuildHeader(sampleName, genoHeader, geno, sampleMeta) + vcf <- .vcfBuildObject(gr, sampleName, hdr, geno, ref, alt) + .vcfWriteByFormat(vcf, outputPath, chrom) + invisible(outputPath) +} + +# Per-variant rowRanges (end extended to the wider of ref / alt for indels). +# @noRd +.vcfBuildRanges <- function(chrom, pos, ref, alt, snpIds) { + GRanges( + chrom, + IRanges( + start = as.integer(pos), + end = as.integer(pos) + pmax(str_length(ref), str_length(alt)) - 1L, + names = snpIds + ) + ) +} + +# VCF header (VCFv4.2, the optional ##SAMPLE block, and the geno header subset +# to the fields actually present). +# @noRd +.vcfBuildHeader <- function(sampleName, genoHeader, geno, sampleMeta = NULL) { + sections <- compact(list( + fileformat = DataFrame(Value = "VCFv4.2", row.names = "fileformat"), + SAMPLE = sampleMeta + )) + hdr <- VariantAnnotation::VCFHeader( + header = exec(DataFrameList, !!!sections), + sample = sampleName + ) + VariantAnnotation::`geno<-`( + hdr, + value = genoHeader[ + is_in(rownames(genoHeader), names(geno)), + , + drop = FALSE + ] + ) +} + +# Assemble + finalize the VCF object (ref / alt / FILTER, sorted). +# @noRd +.vcfBuildObject <- function(gr, sampleName, hdr, geno, ref, alt) { + vcf <- VariantAnnotation::VCF( + rowRanges = gr, + colData = DataFrame(Samples = sampleName, row.names = sampleName), + exptData = list(header = hdr), + geno = SimpleList(geno) + ) + alleled <- VariantAnnotation::`alt<-`( + VariantAnnotation::`ref<-`(vcf, value = DNAStringSet(ref)), + value = .vcfAltList(alt) + ) + filtered <- VariantAnnotation::`fixed<-`( + alleled, + value = `[[<-`( + VariantAnnotation::fixed(alleled), + "FILTER", + value = "PASS" + ) + ) + sort(filtered) +} + +# The ALT column's container. A DNAStringSetList is the normal one, but ALT is +# the one allele field the VCF spec lets be non-DNA: "*" for a variant spanned +# by an upstream deletion, or a symbolic <...> allele. DNAStringSet rejects +# those outright ("key 42 (char '*') not in lookup table"), so such a file +# carries its ALT as a CharacterList. REF is DNA by the spec and unaffected. +# @noRd +.vcfAltList <- function(alt) { + if (isTRUE(all(str_detect(alt, "^[ACGTNacgtn]+$")))) { + return(DNAStringSetList(as.list(alt))) + } + CharacterList(as.list(alt)) +} + +# Write the VCF in the format implied by the output extension. writeVcf appends +# ".bgz" when index = TRUE, so paths are passed WITHOUT the .bgz/.gz suffix. +# @noRd +.vcfWriteByFormat <- function(vcf, outputPath, chrom) { + ext <- file_ext(outputPath) + if (ext == "bcf") { + .vcfWriteBcf(vcf, outputPath, chrom) + } else if (ext == "gz" || ext == "bgz") { + .vcfWriteBgz(vcf, outputPath) + } else { + VariantAnnotation::writeVcf(vcf, outputPath) + } + invisible(NULL) +} + +# BCF path: write a temporary bgzipped VCF, then convert to BCF via asBcf. +# @noRd +#' @importFrom rlang try_fetch +.vcfWriteBcf <- function(vcf, outputPath, chrom) { + tmpVcfStem <- tempfile(fileext = ".vcf") + tmpVcfBgz <- str_c(tmpVcfStem, ".bgz") + on.exit( + unlink(c(tmpVcfBgz, str_c(tmpVcfBgz, ".tbi")), force = TRUE), + add = TRUE + ) + VariantAnnotation::writeVcf(vcf, tmpVcfStem, index = TRUE) + # asBcf appends ".bcf" to destination, so strip the extension. + # Rsamtools disabled asBcf() (>= 2.26 raises "temporarily disabled"), so + # the bare upstream error is translated into something actionable rather + # than surfacing as an opaque failure from a documented output format. + try_fetch( + asBcf( + tmpVcfBgz, + dictionary = unique(chrom), + destination = str_remove(outputPath, "\\.bcf$") + ), + error = function(cnd) { + msg <- glue( + "exportToVcf: 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." + ) + abort(msg, parent = cnd) + } + ) +} + +# bgzip / gzip path: writeVcf always creates .bgz; rename to .gz on request. +# @noRd +.vcfWriteBgz <- function(vcf, outputPath) { + vcfStem <- str_remove(outputPath, "\\.(bgz|gz)$") + VariantAnnotation::writeVcf(vcf, vcfStem, index = TRUE) + actualPath <- str_c(vcfStem, ".bgz") + if (actualPath != outputPath && file.exists(actualPath)) { + file.rename(actualPath, outputPath) + tbiActual <- str_c(actualPath, ".tbi") + if (file.exists(tbiActual)) { + file.rename(tbiActual, str_c(outputPath, ".tbi")) + } + } +} + +# ---- BED: the fSuSiE schema ------------------------------------------------- + +# @noRd +.FMB_FSUSIE_COLUMNS <- c( + "#chr", + "start", + "end", + "ID", + "REF", + "ALT", + "AF", + "PIP", + ".cs.", + "cs_id", + "cs_root", + "grid_resolution", + "grid_positions", + "grid_effects", + "grid_band_halfwidth", + "trait_positions", + "trait_effects", + "joint_traits", + "study", + "context", + "trait", + "method", + "region_id", + "region_start", + "region_end" +) + +# fSuSiE carries the SAME effect twice, at two resolutions, and the published +# table holds both: the fitted curve on the wavelet grid, and that curve +# reinterpolated onto the positions of the traits the fit was run over +# (linearly between grid points, constant past the ends). They are +# complementary -- one is the model, the other is what it predicts where the +# data actually sit -- so both are written by default and `levels` drops a +# group when only one is wanted. +# +# Dropping a group REMOVES its columns from the published order rather than +# re-ordering what is left, so a single-level table is a strict subset of the +# full one. +# @noRd +.FMB_FSUSIE_WAVELET_COLUMNS <- c( + "grid_resolution", + "grid_positions", + "grid_effects", + "grid_band_halfwidth" +) + +# @noRd +# The trait-level group. `joint_traits` rather than a new `trait_names`: these +# ARE the joint members (fsusieTraitEffects() reads them from the row's +# `jointTraits` column), so they use the vocabulary the rest of the schema +# already has for joint membership. "epi_mark" also presumed epigenomic data, +# which a functional fit does not require. +.FMB_FSUSIE_TRAIT_COLUMNS <- c( + "trait_positions", + "trait_effects", + "joint_traits" +) + +# @noRd +.fmbFsusieColumns <- function(levels, csCols = character(0)) { + at <- match(".cs.", .FMB_FSUSIE_COLUMNS) + full <- c( + .FMB_FSUSIE_COLUMNS[seq_len(at - 1L)], + csCols, + .FMB_FSUSIE_COLUMNS[seq(at + 1L, length(.FMB_FSUSIE_COLUMNS))] + ) + setdiff( + full, + c( + if (!is_in("wavelet", levels)) .FMB_FSUSIE_WAVELET_COLUMNS, + if (!is_in("trait", levels)) .FMB_FSUSIE_TRAIT_COLUMNS + ) + ) +} + +# The coverage that KEYS the rows. A functional fit's table is one row per +# (context, credible set), so one level has to define the row; the caller's +# first requested level wins, else the first the fit carries. Membership at +# every other level rides along as its own CS/PUR pair, so a secondary +# coverage is represented rather than silently dropped. +# @noRd +.fmbPrimaryCsLevel <- function(view, coverage) { + levels <- .pubCsLevels(view, coverage) + if (length(levels) == 0L) { + abort(str_c( + "exportToBed(schema = 'fsusie'): the result carries no ", + "credible-set column, so there are no rows to key on." + )) + } + levels[[1L]] +} + +# The source columns .FMB_FSUSIE_COLUMNS already publishes, plus the range +# columns an as.data.frame() adds. The credibleSets view carries a good deal +# more per-variant detail (beta / se / N / logBF / the other coverages and +# their purities), which `columns = "all"` appends. +# @noRd +.FMB_FSUSIE_SOURCE <- c( + "seqnames", + "start", + "end", + "width", + "strand", + "chrom", + "pos", + "variant_id", + "A1", + "A2", + "af", + "pip", + "cs_95", + "study", + "context", + "trait", + "method" +) + +# One (row, credible set) block of the fSuSiE table. `v` is that CS's +# credibleSets() rows; `band` / `marks` are the matching curve views, already +# narrowed to the same row. +# @noRd +.fmbFsusieBlock <- function( + v, + band, + marks, + rowRegionIds, + rowRegions, + added, + levels, + primary, + csCols +) { + key <- .pubIdentityKey(v, .PUB_ROW_COLS)[[1L]] + cs <- v[[str_c("cs_", primary)]][[1L]] + context <- v$context[[1L]] + bKey <- .pubIdentityKey(band, .PUB_ROW_COLS) + mKey <- .pubIdentityKey(marks, .PUB_ROW_COLS) + b <- band[bKey == key & band$cs == cs, , drop = FALSE] + if (nrow(b) == 0L) { + return(NULL) + } + m <- marks[mKey == key & marks$cs == cs, , drop = FALSE] + i <- match(key, names(rowRegionIds)) + regionId <- rowRegionIds[[i]] + rg <- rowRegions[i] + csId <- str_c(context, regionId, str_remove(cs, "^fsusie_"), sep = ":") + out <- tibble( + # The "chr" prefix is kept, as in the other two schemas and in the + # protocol's own phenotype BEDs; stripping it here was unique to this + # table and made one reader rule impossible. + `#chr` = as.character(v$chrom), + start = v$pos - 1L, + end = v$pos, + ID = v$variant_id, + REF = .pubCol(v, "A2"), + ALT = .pubCol(v, "A1"), + # AF, not MAF: the same `af` the other table publishes. Writing + # pmin(af, 1 - af) here lost which allele the frequency referred to, + # so one export of an object was recoverable and the other was not. + AF = .pubCol(v, "af"), + PIP = v$pip, + cs_id = csId, + cs_root = csId, + grid_resolution = nrow(b), + grid_positions = .pubPack(b$pos), + grid_effects = .pubPack(b$effect), + grid_band_halfwidth = .pubPack(b$halfwidth), + trait_positions = .pubPack(m$traitPos), + trait_effects = .pubPack(m$effect), + joint_traits = .pubPack(m$jointTrait), + study = .pubCol(v, "study"), + context = context, + trait = .pubCol(v, "trait"), + method = .pubCol(v, "method"), + region_id = regionId, + region_start = start(rg) - 1L, + region_end = end(rg) + ) + # Membership at EVERY coverage the fit carries, not just the one keying + # the rows -- a secondary coverage would otherwise be silently dropped. + out <- bind_cols(out, .pubFrameCs(v, csCols)) + bind_cols( + select(out, all_of(.fmbFsusieColumns(levels, csCols))), + select(v, all_of(added)) + ) +} + +# @noRd +.fmbFsusieTable <- function(x, columns, levels, coverage) { + fs <- x[as.character(.tupleColumn(x, "method")) == "fsusie"] + if (nrow(fs) == 0L) { + return(NULL) + } + band <- as.data.frame(fsusieCredibleBand(fs)) + if (nrow(band) == 0L) { + abort(str_c( + "exportToBed(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)) + primary <- .fmbPrimaryCsLevel(csTbl, coverage) + csCols <- .pubCsColumns(csTbl, coverage) + marks <- as.data.frame(fsusieTraitEffects(fs)) + # genomicRegion() is the window each row was ANALYSED over (the requested + # region, or the trait's cis window), which is what a publication table + # means by its region -- not the narrower span of whichever variants + # survived QC. + rowRegions <- genomicRegion(fs) + rowRegionIds <- set_names( + .pubRegionIds(rowRegions), + .pubCollectionKey(fs, .PUB_ROW_COLS) + ) + # Splitting the views on (context, cs) alone is only safe for a single + # region: once several regions are combined into one table, two regions can + # each contribute context "c1" / "fsusie_1", and they must stay separate + # rows with their own windows. + pieces <- compact(map( + split( + csTbl, + list( + .pubIdentityKey(csTbl, .PUB_ROW_COLS), + csTbl[[str_c("cs_", primary)]] + ), + drop = TRUE + ), + .fmbFsusieBlock, + band = band, + marks = marks, + rowRegionIds = rowRegionIds, + rowRegions = rowRegions, + added = .pubViewColumns(csTbl, columns, .FMB_FSUSIE_SOURCE), + levels = levels, + primary = primary, + csCols = csCols + )) + if (length(pieces) == 0L) NULL else list_rbind(pieces) +} + +# ---- BED: the topLoci schema ------------------------------------------------ + +# The ONE published vocabulary, shared by both formats. +# +# Fine-mapping results and TWAS weights are the same kind of record -- the +# fine-mapping posterior effect IS the prediction weight -- so they are one +# schema, not two. A file carries the subset of these columns it has anything +# to say about (see .pubDropEmpty), so a weights table is not padded with +# twenty empty posterior columns. +# +# Names are the GWAS-VCF FORMAT keys for every per-variant quantity the spec +# defines, our own uppercase keys alongside them for the quantities it does +# not, and snake_case for the per-fit fields -- which are BED columns here and +# `##SAMPLE` keys in the VCF, so they cannot inherit a spec name. One +# vocabulary across both formats; no translation layer to drift. +# +# The CS columns are NOT here: which coverages exist is fixed at FIT time by +# CredibleSetParam, so they are discovered per input (see .pubCsColumns) and +# spliced in at `.cs.` below. +# @noRd +.PUB_COLUMNS <- c( + # Structural. `ID`/`REF`/`ALT` mirror the VCF's fixed columns -- REF/ALT + # says which allele is which, where `a1`/`a2` left it to convention. + "#chr", + "start", + "end", + "ID", + "REF", + "ALT", + # Frequency and sample size. `AF` is the ALT-allele frequency the spec + # defines; `MAF` is ours, for a source that only recorded the minor + # frequency -- which is not derivable to AF, since it has lost which + # allele it refers to. `NS` is the spec's sample-size key (there is no + # `SS` in GWAS-VCF). + "AF", + "MAF", + "NS", + # Marginal association. `ES`/`SE` are the MARGINAL effect and its error -- + # never a z-score, never silently the posterior. `EZ` carries z, and the + # spec defines it as exactly that: the z "provided if it was used to + # derive the ES and SE fields". `LP` is -log10 p, which is also the better + # representation: invertible, and no underflow at tiny p. + "ES", + "SE", + "EZ", + "LP", + # Posterior effect and its error. This IS the prediction weight: a susie + # posterior mean is sum_l alpha_l * mu_l, which is the TWAS coefficient. + # `conditional_effect` is gone entirely: it was `WGT / PIP` once the + # posterior mean moved onto the scale `coef()` uses, so it duplicated two + # columns that are both here. + "WGT", + "WGTSE", + # Fine-mapping posterior. CS/PUR are spliced in after these. + "PIP", + "LBF", + "LFSR", + ".cs.", + # Identity: the tuple the collections are keyed by. + "study", + "context", + "trait", + "method", + "block_id", + # Provenance. `data_type` is the assay/modality; `data_source` is + # individual-level vs summary-statistics, which `data_type` was being + # mistaken for and which is derivable from whether an ldSketch is present. + "data_type", + "data_source", + "weight_standardized", + # Joint-fit membership. The identity column carries the "joint" sentinel + # and these list the members; the writers used to drop them entirely. + "joint_studies", + "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. + "region_id", + "region_start", + "region_end" +) + +# Always written, so the output is always a valid BED even when every optional +# column is empty. +# @noRd +.PUB_REQUIRED_COLUMNS <- c("#chr", "start", "end", "ID") + +# The credible-set column pair for every coverage the input actually carries. +# Which coverages exist is a FIT-time decision (CredibleSetParam), and +# .fmrRowCs() READS a stored `cs_` column rather than recomputing, so a +# writer can restrict what it publishes but cannot invent a level the fit never +# computed. The VCF path already discovered these; the BED path hardcoded +# 95/70/50, which is the inconsistency this removes. +# @noRd +.pubCsColumns <- function(view, coverage = NULL) { + levels <- .pubCsLevels(view, coverage) + list_c(c( + list(character(0)), + map(levels, .pubCsPair) + )) +} + +# @noRd +.pubCsPair <- function(lv) c(str_c("CS", lv), str_c("PUR", lv)) + +# The available-levels phrase. `str_flatten(character(0))` is "", not NULL, so +# a `%||%` fallback never fires and the message read "Available: ." +# @noRd +.pubLevelList <- function(have) { + if (length(have) == 0L) "" else str_flatten(have, ", ") +} + +# The coverage levels to publish: every `cs_` column the view carries, or +# the requested subset -- with a requested level the fit never computed an +# error that names what IS available, rather than a silently empty column. +# @noRd +.pubCsLevels <- function(view, coverage = NULL) { + have <- str_remove( + names(view)[str_detect(names(view), "^cs_[0-9.]+$")], + "^cs_" + ) + if (is.null(coverage)) { + return(have) + } + want <- as.character(as.numeric(coverage) * 100) + absent <- setdiff(want, have) + if (length(absent) > 0L) { + abort(glue( + "`coverage` asks for {str_flatten(absent, ', ')}, which this fit ", + "did not compute; credible sets are fixed at fit time by ", + "CredibleSetParam. Available: {.pubLevelList(have)}." + )) + } + want +} + +# Splice the discovered CS pairs into the schema at the `.cs.` placeholder. +# @noRd +.pubSchema <- function(csCols) { + at <- match(".cs.", .PUB_COLUMNS) + c( + .PUB_COLUMNS[seq_len(at - 1L)], + csCols, + .PUB_COLUMNS[seq(at + 1L, length(.PUB_COLUMNS))] + ) +} + +# Build one record kind's rows with every schema column present -- the ones it +# carries, and NA for the ones its class cannot know. .pubDropEmpty() then +# removes whatever stayed entirely NA, so the file shows a user only columns +# that say something. +# @noRd +.pubFrame <- function(cols, schema) { + absent <- setdiff(schema, names(cols)) + full <- c(cols, set_names(rep(list(NA), length(absent)), absent)) + select(exec(tibble, !!!full), all_of(schema)) +} + +# Drop the columns that are entirely absent. A fixed schema padded with twenty +# empty columns is worse for a reader than a varying one, and nothing +# downstream breaks: `.pubCol()` already returns NA for a column a table does +# not have, so absent and all-NA are the same thing on the way back in. +# @noRd +.pubDropEmpty <- function(out, keepColumns = character(0)) { + keep <- names(out)[ + is_in(names(out), c(.PUB_REQUIRED_COLUMNS, keepColumns)) | + !map_lgl(out, .pubAllAbsent) + ] + select(out, all_of(keep)) +} + +# @noRd +.pubAllAbsent <- function(v) all(is.na(v)) + +# The columns the caller named explicitly. `"all"` is a request for whatever +# happens to be there, so those stay subject to the drop-empty rule; a named +# column is a request for that column, so it is written even if it is empty. +# @noRd +.pubNamedColumns <- function(columns) { + if (is.null(columns) || identical(columns, "all")) { + return(character(0)) + } + as.character(columns) +} + +# @noRd +.FMB_TOPLOCI_SOURCE <- c( + "seqnames", + "start", + "end", + "width", + "strand", + "chrom", + "pos", + "A1", + "A2", + "variant_id", + "af", + "beta", + "se", + "z", + "trait", + "context", + "cs_95", + "cs_70", + "cs_50", + "cs_95_purity", + "cs_70_purity", + "cs_50_purity", + "posterior_effect", + "posterior_se", + "pip", + "logBF", + "lfsr", + "blockId", + "study", + "method", + "N", + "p" +) + +# @noRd +.fmbTopLociTable <- function(x, signalCutoff, minPurity, columns, coverage) { + tl <- as.data.frame( + topLoci(x, signalCutoff = signalCutoff, minPurity = minPurity) + ) + if (nrow(tl) == 0L) { + return(NULL) + } + # `tl$beta`/`tl$se` are the POSTERIOR mean and sd -- topLoci() is the + # posterior view -- while `mm$beta`/`mm$se` are the MARGINAL estimates. + # Same column name, different quantity, which is why they land in + # different published fields. + mm <- .pubJoinMarginals(tl, as.data.frame(marginalEffects(x))) + win <- .fmbRowWindows(x, tl) + pos <- .pubCol(tl, "pos") + p <- suppressWarnings(as.numeric(.pubCol(mm, "p"))) + csCols <- .pubCsColumns(tl, coverage) + cols <- c( + list( + `#chr` = .pubCol(tl, "chrom"), + start = pos - 1L, + end = pos, + ID = .pubCol(tl, "variant_id"), + REF = .pubCol(tl, "A2"), + ALT = .pubCol(tl, "A1"), + AF = .pubCol(tl, "af"), + NS = .pubCol(tl, "N"), + ES = .pubCol(mm, "beta"), + SE = .pubCol(mm, "se"), + EZ = .pubEz(mm), + LP = if_else(is.na(p) | p <= 0, NA_real_, -log10(p)), + WGT = .pubCol(tl, "posterior_effect"), + WGTSE = .pubCol(tl, "posterior_se"), + PIP = .pubCol(tl, "pip"), + LBF = .pubCol(tl, "logBF"), + LFSR = .pubCol(tl, "lfsr") + ), + .fmbCsValues(tl, csCols), + .pubIdentityValues(x, tl), + list( + region_id = win$id, + region_start = win$start, + region_end = win$end + ) + ) + out <- .pubFrame(cols, .pubSchema(csCols)) + # Per-CS variant-level columns from a fullFit build ride after the fixed + # schema; `columns` adds whatever else the caller asked for after those. + added <- union( + .pubFullFitColumns(tl), + .pubViewColumns(tl, columns, .FMB_TOPLOCI_SOURCE) + ) + bind_cols(out, select(tl, all_of(added))) +} + +# The CS membership / purity values as a tibble, for binding into a block. +# +# `csCols` is never empty here. The only caller runs downstream of +# `.fmbPrimaryCsLevel()`, which aborts outright for a table carrying no +# `cs_` column, and both columns of every level that IS present come back +# from `.pubCsPair()` unconditionally -- so an empty-`csCols` branch would be +# dead by construction. +# @noRd +.pubFrameCs <- function(view, csCols) { + as_tibble( + .fmbCsValues(view, csCols), + .name_repair = "minimal" + ) +} + +# @noRd +.fmbCsValues <- function(tl, csCols) { + set_names(map(csCols, .fmbCsValue, tl = tl), csCols) +} + +# @noRd +.fmbCsValue <- function(nm, tl) { + lv <- str_remove(nm, "^(CS|PUR)") + if (str_starts(nm, "PUR")) { + return(.pubCol(tl, str_c("cs_", lv, "_purity"))) + } + .pubCsIndex(.pubCol(tl, str_c("cs_", lv))) +} + +# A credible-set label ("susie_1", "fsusie_2") as its integer index, which is +# what both formats publish: the prefix is the fitting method, already its own +# field, and an index is filterable in a table and representable in a VCF +# Integer FORMAT field. NA -- not 0 -- for "in no credible set at this +# coverage": NA is missing in both formats, where 0 is a sentinel that could +# collide with a real index. +# @noRd +.pubCsIndex <- function(v) { + idx <- suppressWarnings(as.integer(str_remove(as.character(v), ".*_"))) + replace(idx, is.na(idx) | idx == 0L, NA_integer_) +} + +# The identity and provenance values shared by both record kinds. `data_source` +# is derived rather than stored: a collection's ldSketch is the LD reference the +# fit was run against, so its absence means the fit saw individual-level data. +# @noRd +.pubIdentityValues <- function(x, view) { + list( + study = .pubCol(view, "study"), + context = .pubCol(view, "context"), + trait = .pubCol(view, "trait"), + method = .pubCol(view, "method"), + block_id = .pubCol(view, "blockId"), + data_type = .pubCol(view, "dataType"), + data_source = .pubRowOrDerived(view, "dataSource", .pubDataSource(x)), + weight_standardized = .pubCol(view, "standardized"), + joint_studies = .pubCol(view, "jointStudies"), + joint_contexts = .pubCol(view, "jointContexts"), + joint_traits = .pubCol(view, "jointTraits") + ) +} + +# The collection-level fallback for `data_source`: an ldSketch is the LD +# reference a fit was run against, so its absence means individual-level data. +# Only a fallback -- a row that recorded its own wins, because a combined +# collection can hold rows of both kinds and has only one ldSketch. +# @noRd +.pubDataSource <- function(x) { + if (is.null(ldSketch(x))) "individual" else "sumstat" +} + +# @noRd +# Absent OR entirely empty both mean "the rows did not record this", because +# .fmrRowMetadata() NA-fills a column the collection lacks -- so testing only +# for absence would return the NA column and never reach the fallback. +# `EZ` only when the SOURCE supplied z. The spec defines the field as the z +# "provided if it was used to derive the ES and SE fields", so publishing a z +# that pecotmr itself computed as beta/se would invert its meaning -- and a +# reader would then believe ES/SE were derived when they were recorded. +# @noRd +.pubEz <- function(view, n = NULL) { + # `isTRUE()` is length-1 only: `isTRUE(c(TRUE, TRUE))` is FALSE, so the + # all-or-nothing test this used never fired for a view with more than one + # variant and EZ was never published at all. Per ROW anyway, matching + # `.vcfSuppliedZ()`: a file can hold a mix, and a derived z must not + # borrow a neighbour's provenance. + supplied <- as.logical(.pubCol(view, "z_supplied", n)) + z <- as.numeric(.pubCol(view, "z", n)) + if (!any(!is.na(supplied) & supplied)) { + return(if (is.null(n)) NA_real_ else rep(NA_real_, n)) + } + replace(z, is.na(supplied) | !supplied, NA_real_) +} + +# @noRd +.pubRowOrDerived <- function(view, nm, fallback) { + v <- .pubCol(view, nm) + if (all(is.na(v))) { + return(fallback) + } + v +} + +# The analysis window of the collection row each long-view row came from, +# matched on the row identity so a folded multi-row table keeps each row's own +# window rather than the first one's. +# @noRd +.fmbRowWindows <- function(x, df) { + rg <- genomicRegion(x) + idx <- match( + .pubIdentityKey(df, .PUB_ROW_COLS), + .pubCollectionKey(x, .PUB_ROW_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 + # against upstream region lists rather than a coordinate pair. + list( + id = .pubRegionIds(rg)[idx], + start = start(rg)[idx] - 1L, + end = end(rg)[idx] + ) +} + +# The analysis window of the collection row each long-view row came from, +# matched on the row identity so a folded multi-row table keeps each row's own +# window rather than the first one's. +# @noRd + +# ---- BED: fine-mapping entry point ------------------------------------------ + +#' @rdname exportToBed +#' @export +setMethod( + "exportToBed", + signature("list"), + function(x, outputPath, ...) { + exportToBed(.pubCombineList(x), outputPath, ...) + } +) + +# `region_ID` / `region_start` / `region_end` come from genomicRegion() -- the +# 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 +#' @export +setMethod( + "exportToBed", + signature("FineMappingResultBase"), + function( + x, + outputPath, + schema = c("topLoci", "fsusie"), + signalCutoff = 0.025, + minPurity = NULL, + coverage = NULL, + levels = c("wavelet", "trait"), + columns = NULL, + extraColumns = NULL + ) { + schema <- arg_match(schema) + levels <- arg_match(levels, multiple = TRUE) + assertString(outputPath) + .pubRequireFullFit(x, .fmbIncompleteRows(x), "exportToBed") + if (identical(schema, "fsusie")) { + return(.pubWriteTable( + .fmbFsusieTable(x, columns, levels, coverage), + outputPath, + naString = "NA", + index = TRUE, + emptySchema = .fmbFsusieColumns(levels), + extraColumns = extraColumns + )) + } + .pubWriteTable( + .fmbTopLociTable(x, signalCutoff, minPurity, columns, coverage), + outputPath, + naString = "NA", + index = TRUE, + keepColumns = .pubNamedColumns(columns), + extraColumns = extraColumns + ) + } +) + +# ---- BED: the TWAS-weight schemas ------------------------------------------- + +# The source columns the weights schema already publishes. Unlike the +# fine-mapping views, a TwasWeights element carries nothing else today -- its +# variants hold exactly A1 / A2 / weight -- so `columns = "all"` is a no-op on +# a pipeline-built collection and exists for the custom-built ones that +# annotate their variants further. +# @noRd +.TWB_WEIGHT_SOURCE <- c("A1", "A2", "weight") + +# A zero-row frame naming every variant-level column ANY row's variants carry. +# `columns` resolves against this rather than against one row, because the +# published schema must not vary row by row: a column one row has and another +# lacks has to become an NA cell, not a column that appears halfway down. +# @noRd +.twbVariantColumns <- function(x) { + nms <- unique(list_c(c( + list(character(0)), + map(seq_len(nrow(x)), .twbRowVariantColumns, x = x) + ))) + as_tibble( + set_names(rep(list(character()), length(nms)), nms), + .name_repair = "minimal" + ) +} + +# @noRd +.twbRowVariantColumns <- function(i, x) colnames(mcols(x[[i]])) + +# Per-row identity and payload provenance, as a tibble parallel to the +# collection's rows. The identity axes are mcols columns on a TwasWeights, not +# element fields, so they are read through `.tupleColumn()`. +# @noRd +.twbRowMetadata <- function(x) { + tibble( + study = .pubTupleColumn("study", x), + trait = .pubTupleColumn("trait", x), + context = .pubTupleColumn("context", x), + method = .pubTupleColumn("method", x), + standardized = .twbColumnOr(x, "standardized", as.logical, NA), + dataType = .twbListColumn(x, "dataType"), + dataSource = .pubDataSource(x), + jointStudies = .twbColumnOr( + x, + "jointStudies", + as.character, + NA_character_ + ), + jointContexts = .twbColumnOr( + x, + "jointContexts", + as.character, + NA_character_ + ), + jointTraits = .twbColumnOr( + x, + "jointTraits", + as.character, + NA_character_ + ) + ) +} + +# An mcols column read through `coerce`, or a recycled default when the +# collection does not carry it. +# @noRd +.twbColumnOr <- function(x, nm, coerce, default) { + if (!is_in(nm, .tupleColumnNames(x))) { + return(rep(default, nrow(x))) + } + coerce(.tupleColumn(x, nm)) +} + +# A per-row List column flattened to one string per row. +# +# No absent-column branch, unlike `.twbColumnOr()` above: this is only ever +# asked for `dataType`, which `TwasWeights()` materializes for every row even +# when no row declares one -- and that constructor is the only way to build +# the class, so the column is always there. +# @noRd +.twbListColumn <- function(x, nm) { + map_chr(as.list(.tupleColumn(x, nm)), .twbScalarChr) +} + +# One List cell as a single string: an absent value becomes NA, and a +# multi-value cell is ";"-packed rather than silently truncated. +# @noRd +.twbScalarChr <- function(v) { + if (length(v) == 0L) NA_character_ else .pubPack(v) +} + +# The weight-matrix column labels of one row. A plain numeric vector -- the +# univariate case, and what a multivariate fit is split into one row per +# context -- has no feature axis, so it gets a single NA label. A matrix keeps +# one label per column: its colname when it has them (fSuSiE's functional grid +# positions), else its index. +# @noRd +.twbWeightLabels <- function(w) { + if (is.null(dim(w))) { + return(NA_character_) + } + colnames(w) %||% as.character(seq_len(ncol(w))) +} + +# The k-th weight column of a row's weights, as a plain numeric vector. +# @noRd +.twbWeightColumn <- function(k, w) { + if (is.null(dim(w))) as.numeric(w) else as.numeric(w[, k]) +} + +# Fine-mapping methods have no business in a weights export: their "weights" +# are the fine-mapping posterior re-expressed, so the FineMappingResult says +# strictly more. Those rows are skipped with a message rather than written. +# @noRd +.TWB_FINE_MAPPING_METHODS <- c( + "susie", + "susie_inf", + "susie_ash", + "mvsusie", + "fsusie" +) + +# @noRd +.twbExportableRows <- function(x, label = "exportToBed") { + methods <- .pubTupleColumn("method", x) + skip <- which(is_in(methods, .TWB_FINE_MAPPING_METHODS)) + if (length(skip) > 0L) { + inform(glue( + "{label}: skipping {length(skip)} fine-mapping-derived ", + "row(s) ({str_flatten(unique(methods[skip]), ', ')}). Those ", + "weights are the fine-mapping posterior re-expressed -- export ", + "the FineMappingResult instead, which carries the posterior, its ", + "standard error and the credible sets." + )) + } + setdiff(seq_len(nrow(x)), skip) +} + +# One (row, weight column) block of the weights table: every variant of the +# row, carrying that column's weight and the row's identity. A weight MATRIX +# column is a member of a joint fit, so `trait` names the member and +# `joint_traits` keeps the full membership. +# @noRd +.twbWeightBlock <- function(k, gr, w, labels, ident, win, af, schema, added) { + mc <- mcols(gr) + n <- length(gr) + cols <- c( + list( + `#chr` = as.character(seqnames(gr)), + start = start(gr) - 1L, + end = start(gr), + ID = .grVariantIds(gr), + REF = as.character(.pubCol(mc, "A2", n)), + ALT = as.character(.pubCol(mc, "A1", n)), + AF = af, + WGT = .twbWeightColumn(k, w), + study = ident$study, + context = ident$context, + trait = .twbTraitOf(labels[[k]], ident$trait), + method = ident$method, + data_type = ident$dataType, + data_source = ident$dataSource, + weight_standardized = ident$standardized, + joint_studies = ident$jointStudies, + joint_contexts = ident$jointContexts, + joint_traits = ident$jointTraits, + region_id = win$id, + region_start = win$start, + region_end = win$end + ) + ) + bind_cols(.pubFrame(cols, schema), .twbAddedColumns(mc, added, n)) +} + +# The caller-requested variant-level columns of one block, NA-filled for a row +# whose variants do not carry them. +# @noRd +.twbAddedColumns <- function(mc, added, n) { + # A zero-column tibble still has to declare its row count, or bind_cols + # refuses to recycle the block it is being joined to. + if (length(added) == 0L) { + return(tibble(.rows = n)) + } + as_tibble( + set_names(map(added, .pubCol, df = mc, n = n), added), + .name_repair = "minimal" + ) +} + +# The trait a weight column belongs to: the matrix column's label when it has +# one (a joint fit's member), else the row's own trait. `%||%` is no use here -- +# a plain weight vector's label is NA, not NULL. +# @noRd +.twbTraitOf <- function(label, trait) { + if (is.na(label)) trait else label +} + +# @noRd +.twbWeightRows <- function(i, x, meta, regions, regionIds, schema, added) { + gr <- x[[i]] + w <- mcols(gr)$weight + labels <- .twbWeightLabels(w) + list_rbind(map( + seq_along(labels), + .twbWeightBlock, + gr = gr, + w = w, + labels = labels, + ident = slice(meta, i), + win = list( + id = .pubRegionIds(regions)[[i]], + start = start(regions)[[i]] - 1L, + end = end(regions)[[i]] + ), + af = .twbVariantAf(x, gr), + schema = schema, + added = added + )) +} + +# Per-variant allele frequency, from the collection's LD panel when it has one. +# A TwasWeights element records only alleles and a weight, so without a panel +# there is no frequency to publish -- and `AF` is what the standardized-to-raw +# weight conversion needs, so its absence is worth seeing rather than faking. +# @noRd +.twbVariantAf <- function(x, gr) { + panel <- ldSketch(x) + if (is.null(panel)) { + return(NA_real_) + } + rr <- try_fetch( + SummarizedExperiment::rowRanges(panel), + error = function(cnd) NULL + ) + if (is.null(rr) || !is_in("af", colnames(mcols(rr)))) { + return(NA_real_) + } + as.numeric(mcols(rr)$af)[match(.grVariantIds(gr), .grVariantIds(rr))] +} + +# @noRd +.twbWeightsTable <- function(x, columns, coverage) { + rows <- .twbExportableRows(x) + if (length(rows) == 0L) { + abort(str_c( + "exportToBed: every row is fine-mapping-derived, so there is ", + "nothing to write as weights. Export the FineMappingResult." + )) + } + schema <- .pubSchema(.pubCsColumns(tibble(), coverage)) + regions <- genomicRegion(x) + pieces <- compact(map( + rows, + .twbWeightRows, + x = x, + meta = .twbRowMetadata(x), + regions = regions, + regionIds = .pubRegionIds(regions), + schema = schema, + added = .pubViewColumns( + .twbVariantColumns(x), + columns, + .TWB_WEIGHT_SOURCE + ) + )) + if (length(pieces) == 0L) NULL else list_rbind(pieces) +} + +# ---- BED: TWAS-weight entry point ------------------------------------------- + +# One table, one row per (variant, weight column). There is no companion +# performance table: cross-validation metrics describe 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. They stay on the object, +# where cvResult() returns them and the caller tabulates whatever they need. +#' @rdname exportToBed +#' @export +setMethod( + "exportToBed", + signature("TwasWeights"), + function( + x, + outputPath, + coverage = NULL, + columns = NULL, + extraColumns = NULL + ) { + assertString(outputPath) + .pubRequireFullFit(x, .twbIncompleteRows(x), "exportToBed") + .pubWriteTable( + .twbWeightsTable(x, columns, coverage), + outputPath, + naString = "NA", + index = TRUE, + keepColumns = .pubNamedColumns(columns), + extraColumns = extraColumns + ) + } +) diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index e0f5450c..be92e164 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -2911,7 +2911,13 @@ effectiveN <- function(nCase, nControl) { "SE", "P", "N_CASE", - "N_CONTROL" + "N_CONTROL", + # Lower case, unlike its neighbours, because it is not a statistic: + # it is the per-variant flag saying whether `Z` was supplied by the + # source or derived by pecotmr from BETA / SE, and GWAS-VCF's `EZ` + # means only the former. Same name as the fine-mapping marginal + # view's, so the vocabulary is one. + "z_supplied" ) use <- intersect(c(baseCols, optCols), colnames(df)) S4Vectors::`mcols<-`( diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index fa9bae4a..094ef340 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -259,7 +259,7 @@ # 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 getTopLoci. +# ambiguity; it is the aggregate counterpart used by topLoci(). .fmrRowsMatching <- function( x, studyName = NULL, @@ -296,7 +296,16 @@ # method). Columns the collection lacks are NA-filled so QTL and GWAS results # yield the same metadata shape. Safe for zero-row collections. .fmrRowMetadata <- function(x) { - cols <- c("study", "context", "trait", "blockId", "method") + cols <- c( + "study", + "context", + "trait", + "blockId", + "method", + "dataType", + "dataSource", + "standardized" + ) n <- nrow(x) as_tibble(set_names(map(cols, .fmrMetadataCol, x = x, n = n), cols)) } @@ -311,21 +320,34 @@ bind_rows(parts) } -# Internal: read the per-row `region` GRanges column of a collection, or an -# empty GRanges when the collection carries none. Shared by genomicRegion on -# TwasWeights and FineMappingResultBase (region is a uniform column across the -# family; no derivation from topLoci / blockId). -# The per-element span, DERIVED from the ranges rather than read from a stored -# `region` column (spec 4.4). range() is always in sync by construction, where -# a stored window had no correct update rule under subsetRegion() and would -# quietly go stale. `blockId` carries the nominal block identity instead. +# Internal: the per-row analysis WINDOW -- the genomic interval each row's fit +# was run over, as stored on the `region` column. Shared by genomicRegion() on +# TwasWeights and FineMappingResultBase. +# +# Stored rather than derived, because it is the half that cannot be recovered: +# QC and screening drop variants before the fit, so the realized span of the +# variants present is narrower than the window that was analysed (a fit over +# chr22:10,000,000-18,000,000 whose variants span 10,414,272-16,916,492). The +# span IS recoverable -- it is just range(x) -- so nothing is lost by deriving +# 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 +# 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. # @noRd .getRegionColumn <- function(x) { if (nrow(x) == 0L) { return(GenomicRanges::GRanges()) } - # No stored region column: nothing carries one any more, so the span is - # always derived from the elements' own ranges. + if (is_in("region", .tupleColumnNames(x))) { + return(.tupleColumn(x, "region")) + } unlist(range(x), use.names = FALSE) } @@ -349,13 +371,109 @@ 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. +.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) + } + if (length(gr) == 1L) gr else range(gr)[1L] +} + +# Internal: `.asAnalysisWindow()` replicated to one range per row, for the +# constructors that take a whole collection's worth of rows at once. +.analysisWindowForRows <- function(region, n) { + gr <- .asAnalysisWindow(region) + if (is.null(gr) || n == 0L) { + return(NULL) + } + rep(gr, n) +} + # Internal: append a validated `region` GRanges to a constructor's column list -# (no-op when region is NULL). Shared by the TwasWeights / FineMappingResult +# (no-op when NULL). Shared by the TwasWeights / FineMappingResult # constructors so the provenance column is added identically everywhere. +# Internal: an optional per-row provenance column. One helper for all three +# (`dataType`, `dataSource`, `standardized`) since they differ only in name and +# coercion. +# +# `dataSource` is per ROW, not per collection: it used to be derived from the +# collection's single `ldSketch` slot, so after combineFineMappingResults() +# folded individual-level and RSS-derived fits together every row got the +# combined object's answer. +# +# `standardized` gets the same treatment fine-mapping needed anyway: the +# posterior effect IS the prediction weight, so it carries the same genotype- +# scale ambiguity as a TWAS weight -- and the fit cannot answer it (susie +# records whether IT scaled, not whether the supplied X was already +# standardized), so it has to be recorded rather than derived. +# @noRd +.appendProvenanceCol <- function(cols, value, nm, n, coerce = as.character) { + if (is.null(value)) { + return(cols) + } + v <- coerce(value) + if (!is_in(length(v), c(1L, n))) { + abort(glue("`{nm}` must be length 1 or the same length as `study`.")) + } + c(cols, set_names(list(rep(v, length.out = n)), nm)) +} + +# @noRd +.appendDataTypeCol <- function(cols, dataType, n) { + .appendProvenanceCol(cols, dataType, "dataType", n) +} + +# @noRd +.appendFmProvenanceCols <- function( + cols, + dataType, + dataSource, + standardized, + n +) { + cols <- .appendProvenanceCol(cols, dataType, "dataType", n) + cols <- .appendProvenanceCol(cols, dataSource, "dataSource", n) + .appendProvenanceCol(cols, standardized, "standardized", n, as.logical) +} + +.appendRegionCol <- function(cols, region, n) { + if (is.null(region)) { + return(cols) + } + if (!methods::is(region, "GRanges")) { + abort("`region` must be a GRanges (one range per row) or NULL.") + } + if (length(region) != n) { + abort("`region` must have the same length as `study`.") + } + c(cols, list(region = region)) +} # Internal: validate the optional `region` GRanges column (one range per row), # shared by the TwasWeights / FineMappingResult validity methods. Returns a # character vector of errors (empty when valid or the column is absent). +.validateRegionColumn <- function(object) { + if (!is_in("region", .tupleColumnNames(object))) { + return(character(0)) + } + region <- .tupleColumn(object, "region") + res <- checkClass(region, "GRanges") + if (!isTRUE(res)) { + return(str_c("'region' column ", res)) + } + if (length(region) != nrow(object)) { + return("'region' column must have one range per row") + } + character(0) +} # Internal: trait-position provenance. One GRanges per trait carrying the # molecular feature's OWN genomic coordinates (gene/peak range; TSS = start()), @@ -842,18 +960,19 @@ # @noRd .fmrRowResolveWeights <- function(parts) { empty <- list(variantIds = character(0), weights = numeric(0)) - # The topLoci posterior view projects the effect to `beta`; use it as the - # per-variant weight, aligned with variant_id. + # The topLoci posterior view projects the effect to `posterior_effect`, + # and that effect IS the per-variant weight -- a susie posterior mean is + # the TWAS coefficient. Aligned with variant_id. tl <- .fmrRowTopLoci(parts) if ( is.null(tl) || nrow(tl) == 0L || - !all(is_in(c("variant_id", "beta"), names(tl))) + !all(is_in(c("variant_id", "posterior_effect"), names(tl))) ) { return(empty) } vids <- as.character(tl$variant_id) - w <- as.numeric(tl$beta) + w <- as.numeric(tl$posterior_effect) ok <- !is.na(vids) & !is.na(w) if (!any(ok)) { return(empty) diff --git a/R/twasWeights.R b/R/twasWeights.R index 44df146a..0fcc1731 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -97,6 +97,7 @@ setClass( c( .twasValidateEntries(object), .validateTraitPosColumn(object), + .validateRegionColumn(object), .twasValidateJointCols(object, jointCols), .twasValidateKeyUniqueness(object, jointCols) ) @@ -174,6 +175,11 @@ setClass( #' @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{TwasWeights} object. #' @examples #' twe <- twasWeightsRow(variantIds = sprintf("chr1:%d:A:G", 100L * (1:4)), @@ -195,6 +201,7 @@ TwasWeights <- function( jointContexts = NULL, jointTraits = NULL, traitPos = NULL, + region = NULL, ldSketch = NULL ) { .twasAssertArgs( @@ -220,6 +227,7 @@ TwasWeights <- function( jointContexts, jointTraits, traitPos, + region, n ) obj <- new( @@ -272,6 +280,7 @@ TwasWeights <- function( jointContexts, jointTraits, traitPos, + region, n ) { baseCols <- c( @@ -290,7 +299,7 @@ TwasWeights <- function( jointTraits, n ) - .appendTraitPosCol(withJoint, traitPos, n) + .appendRegionCol(.appendTraitPosCol(withJoint, traitPos, n), region, n) } # One entry -> its element: the variants as a GRanges, with the per-variant @@ -362,6 +371,7 @@ TwasWeights <- function( #' @export setMethod("genomicRegion", "TwasWeights", function(x) .getRegionColumn(x)) + #' @rdname traitPosition #' @export setMethod("traitPosition", "TwasWeights", function(x) { diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index 811f027e..3cc2440e 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -1238,6 +1238,26 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' something the input cannot do. #' @param weightsDataType Optional data-type label recorded on every #' \code{TwasWeightsRow$dataType} (e.g. \code{"expression"}). +#' @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. +#' +#' 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 +#' --- exactly so for glmnet / ncvreg / L0Learn / mr.ash / the Bayesian +#' alphabet and for \code{susieWeights()} --- while the DPR samplers are +#' not scale-equivariant at all, so a uniform rescale of \code{X} changes +#' their fit and not merely its units. The chosen scale is also the one the +#' LD correlations and z-scores behind a TWAS Z already use. A +#' summary-statistics fit needs nothing done. +#' +#' \code{\link{learnTwasWeights}} still takes \code{weightStandardized}: +#' there the caller supplies \code{X} themselves, so only they can say. #' @param verbose Verbosity (0 silent, 1 default, 2 includes external package #' messages). #' @param seed Integer or \code{NULL}. When supplied (\code{QtlDataset} path), @@ -1505,6 +1525,7 @@ setGeneric("twasWeightsPipeline", function(data, ...) { ensembleArgs = .ensembleResolve(ensembleArgs), fitFullData = fitFullData, weightsDataType = weightsDataType, + standardized = .qtlScaleResiduals(data, residualizationArgs), fitRetention = fitRetention, estimatePi = estimatePi, verbose = verbose, @@ -1796,6 +1817,7 @@ setMethod( ensembleArgs, fitFullData, weightsDataType, + standardized, fitRetention, estimatePi, verbose, @@ -1812,7 +1834,12 @@ setMethod( fitFullData = fitFullData, dataType = weightsDataType, fitRetention = fitRetention, - standardized = FALSE, + # 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. + standardized = standardized, estimatePi = estimatePi, verbose = verbose, seed = seed, diff --git a/R/variantId.R b/R/variantId.R index a8f8e70e..b162df99 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -1191,16 +1191,24 @@ matchVariants <- function( #' @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) } - if (!str_detect(region, "^chr[0-9XY]+:[0-9]+-[0-9]+$")) { - abort("Input string format must be 'chr:start-end'.") + # 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, "[:-]") + parts <- str_split_1(region, "[:_-]") tibble( chrom = canonChrom(parts[1]), start = as.integer(parts[2]), diff --git a/R/vcfWriter.R b/R/vcfWriter.R deleted file mode 100644 index 7aecc39a..00000000 --- a/R/vcfWriter.R +++ /dev/null @@ -1,695 +0,0 @@ -#' @include AllGenerics.R -#' @importFrom S4Vectors DataFrame SimpleList mcols -#' @importFrom GenomicRanges GRanges seqnames -#' @importFrom IRanges DataFrameList -#' @importFrom Biostrings DNAStringSet DNAStringSetList -#' @importFrom Rsamtools asBcf -#' @importFrom tools file_ext -#' @importFrom stringr str_sub -#' @importFrom purrr map map_chr keep set_names list_flatten -NULL - -#' @rdname writeSumStatsVcf -#' @export -setMethod( - "writeSumStatsVcf", - signature("GwasSumStats"), - function(x, outputPath, sampleName = NULL, studyName = NULL) { - if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { - abort( - "Package 'VariantAnnotation' is required for writeSumStatsVcf" - ) - } - studyName <- .vcfResolveStudy(x, studyName) - ss <- sumStats(x, studyName = studyName) - mc <- mcols(ss) - .writeVcfImpl( - chrom = as.character(seqnames(ss)), - pos = start(ss), - ref = mc$A2, - alt = mc$A1, - snpIds = mc$SNP, - geno = .vcfSumstatsGeno(mc, length(ss)), - genoHeader = .vcfSumstatsGenoHeader(), - sampleName = sampleName %||% studyName, - outputPath = outputPath - ) - } -) - -# Select which study to write (a GwasSumStats can hold many); a single-study -# collection defaults to its one study. -# @noRd -.vcfResolveStudy <- function(x, studyName) { - if (!is.null(studyName)) { - return(studyName) - } - if (nrow(x) != 1L) { - msg <- glue( - "This GwasSumStats has {nrow(x)} studies. ", - "Pass `study = ` to select one." - ) - abort(msg) - } - as.character(x$study[[1L]]) -} - -# Per-sample geno matrices (ES / SS / AF) for the fields present in the mcols. -# @noRd -.vcfSumstatsGeno <- function(mc, nSnps) { - compact(list( - ES = if (is_in("Z", colnames(mc))) matrix(mc$Z, nSnps), - SS = if (is_in("N", colnames(mc))) { - matrix(as.integer(mc$N), nSnps) - }, - AF = if (is_in("MAF", colnames(mc))) matrix(mc$MAF, nSnps) - )) -} - -# The fixed FORMAT header for the sumstats geno fields (ES / SS / AF). -# @noRd -.vcfSumstatsGenoHeader <- function() { - DataFrame( - Number = c("A", "A", "A"), - Type = c("Float", "Integer", "Float"), - Description = c( - "Z-score of effect size estimate", - "Sample size", - "Minor allele frequency" - ), - row.names = c("ES", "SS", "AF") - ) -} - -#' @rdname writeSumStatsVcf -#' @export -setMethod( - "writeSumStatsVcf", - signature("FineMappingResultBase"), - function( - x, - outputPath, - sampleName = NULL, - studyName = NULL, - context = NULL, - trait = NULL, - method = NULL, - splitByContext = FALSE, - splitByTrait = FALSE - ) { - if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { - abort( - "Package 'VariantAnnotation' is required for writeSumStatsVcf" - ) - } - - # Resolve the set of rows to write. With both selectors NULL and no - # split flags, the collection must have exactly one row. Splitting - # iterates over the unique values of the requested axis. - rowSpecs <- .resolveFineMappingRows( - x, - studyName = studyName, - context = context, - trait = trait, - method = method, - splitByContext = splitByContext, - splitByTrait = splitByTrait - ) - invisible(map_chr( - rowSpecs, - .writeFineMappingVcfSpec, - x = x, - outputPath = outputPath, - sampleName = sampleName, - splitByContext = splitByContext, - splitByTrait = splitByTrait - )) - } -) - -# @noRd -.writeFineMappingVcfSpec <- function( - spec, - x, - outputPath, - sampleName, - splitByContext, - splitByTrait -) { - .writeFineMappingVcf( - x, - spec, - outputPath = outputPath, - sampleName = sampleName, - splitByContext = splitByContext, - splitByTrait = splitByTrait - ) -} - -# Narrow a row-index vector to those rows whose `axis` column equals the -# caller's requested value. `.tupleColumn()` not `[[`: on a RangedTupleList -# `[[` extracts an ELEMENT, while the identity axes live in mcols. -# @noRd -.vcfNarrowRows <- function(rows, axis, x, selectors) { - rows[as.character(.tupleColumn(x, axis))[rows] == selectors[[axis]]] -} - -# Resolve which (study, context, trait, method) rows to write. Without -# the split flags this returns a single spec; with `splitByContext` or -# `splitByTrait` the collection's rows are walked and one spec is emitted -# per row (after applying any explicit selector filters). -# @noRd -.resolveFineMappingRows <- function( - x, - studyName, - context, - trait, - method, - splitByContext, - splitByTrait -) { - cols <- .tupleColumnNames(x) - hasContextSlot <- is_in("context", cols) - hasTraitSlot <- is_in("trait", cols) - selectors <- compact(list( - study = studyName, - context = if (hasContextSlot) context, - trait = if (hasTraitSlot) trait, - method = method - )) - rows <- reduce( - names(selectors), - .vcfNarrowRows, - x = x, - selectors = selectors, - .init = seq_len(nrow(x)) - ) - if (length(rows) == 0L) { - abort("writeSumStatsVcf: no rows match the supplied selectors.") - } - if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { - if (length(rows) != 1L) { - msg <- glue( - "This FineMappingResult has {length(rows)} matching rows. ", - "Pass `study`/`context`/`trait`/`method` to select one, or ", - "set `splitByContext = TRUE` / `splitByTrait = TRUE` to emit ", - "one file per row." - ) - abort(msg) - } - return(list(.rowSpec(rows[[1L]], x))) - } - map(rows, .rowSpec, x = x) -} - -# Build a (study, context, trait, method) spec list for one row index. -# @noRd -.rowSpec <- function(r, x) { - list( - 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] - ) -} - -# Extract column `nm` from `df`, or an all-NA vector of length nSnps when -# absent. -# @noRd -.vcfCol <- function(df, nm, nSnps) { - if (!is.null(df) && is_in(nm, names(df))) df[[nm]] else rep(NA, nSnps) -} - -# One VCF FORMAT field spec: name, per-variant `values`, VCF `type` -# (Float/Integer), and header `desc`. Number is always "A" (per-allele). -# @noRd -.vcfSpec <- function(name, values, type, desc) { - list(name = name, values = values, type = type, desc = desc) -} - -# Core FORMAT fields shared by univariate + posterior VCFs: effect size -# (posterior conditional effect, else marginal beta), standard error, -log10 -# p-value, sample size, and effect-allele frequency. Returns a list of specs; -# empty (all-NA) ones are dropped downstream. -# @noRd -.vcfCoreSpecs <- function(base, m, nSnps) { - # The conditional effect when the fit reported one, else the marginal. - conditional <- .vcfCol(base, "conditional_effect", nSnps) - es <- if (all(is.na(conditional))) { - .vcfCol(m, "beta", nSnps) - } else { - conditional - } - baseAf <- .vcfCol(base, "af", nSnps) - af <- if (all(is.na(baseAf))) .vcfCol(m, "af", nSnps) else baseAf - p <- .vcfCol(m, "p", nSnps) - lp <- if_else(is.na(p) | p <= 0, NA_real_, -log10(p)) - list( - .vcfSpec( - "ES", - es, - "Float", - str_c( - "Effect size (posterior conditional effect, ", - "else marginal beta), effect allele" - ) - ), - .vcfSpec( - "SE", - .vcfCol(m, "se", nSnps), - "Float", - "Standard error of the marginal effect-size estimate" - ), - .vcfSpec( - "LP", - lp, - "Float", - "-log10 p-value of the marginal univariate effect" - ), - .vcfSpec( - "SS", - as.integer(.vcfCol(m, "N", nSnps)), - "Integer", - "Sample size" - ), - .vcfSpec("AF", af, "Float", "Allele frequency (effect allele)") - ) -} - -# Credible-set FORMAT fields. pecotmr emits CS (+ PUR when -# a purity column exists) for EVERY cs_ column present, so coverage -# levels are data-driven rather than the 50/70/95 xqtl-protocol default. -# @noRd -.vcfCsSpecs <- function(base) { - csCols <- names(base)[str_detect(names(base), "^cs_[0-9.]+$")] - perCol <- map(csCols, .vcfCsColSpecs, base = base) - list_flatten(perCol) -} - -# Per-CS variant-level fullFit FORMAT fields (within_cs_pip scalar plus the -# wide within_cs_pip_ / cs_logbf_ / cs_effect_ sets emitted when -# the topLoci was built with fullFit = TRUE). Each column becomes an uppercase -# field. -# @noRd -.vcfFullFitSpecs <- function(base) { - cols <- names(base)[str_detect( - names(base), - "^(within_cs_pip|cs_logbf_|cs_effect_)" - )] - map(cols, .vcfFullFitColSpec, base = base) -} - -# Posterior FORMAT fields, only when a fine-mapping posterior table exists: -# PIP, per-variant log Bayes factor, local false sign rate, plus the dynamic -# credible-set and fullFit column sets. -# @noRd -.vcfPosteriorSpecs <- function(base, nSnps) { - fixed <- list( - .vcfSpec( - "PIP", - .vcfCol(base, "pip", nSnps), - "Float", - "Posterior inclusion probability" - ), - .vcfSpec( - "LBF", - .vcfCol(base, "logBF", nSnps), - "Float", - "Per-variant log Bayes factor (max single effect)" - ), - .vcfSpec( - "LFSR", - .vcfCol(base, "lfsr", nSnps), - "Float", - "Local false sign rate (per-condition posterior)" - ) - ) - c(fixed, .vcfCsSpecs(base), .vcfFullFitSpecs(base)) -} - -# Resolve the per-variant body: the fine-mapping POSTERIOR (topLoci at -# signalCutoff 0 = every fitted variant, carrying pip / CS membership / -# conditional effect) joined to the MARGINAL univariate sumstats -# (marginalEffects) where those exist. mvSuSiE / fSuSiE have no marginal -# sumstats, so the posterior drives the variant set; univariate susie adds -# marginal ES=beta / SE / LP / AF on top. Returns list(base, m, hasPost). -# @noRd -.vcfResolveBody <- function(entry, sn) { - post <- try_fetch( - as_tibble(as.data.frame( - S4Vectors::mcols(topLoci(entry, signalCutoff = 0)) - )), - error = function(cnd) NULL - ) - marg <- try_fetch( - as_tibble(marginalEffects(entry)), - error = function(cnd) NULL - ) - hasPost <- !is.null(post) && nrow(post) > 0L - hasMarg <- !is.null(marg) && nrow(marg) > 0L - if (hasPost) { - base <- post - m <- if (hasMarg) { - slice(marg, match(base$variant_id, marg$variant_id)) - } else { - NULL - } - } else if (hasMarg) { - base <- marg - m <- marg - } else { - msg <- glue("writeSumStatsVcf: entry [{sn}] has no variants to write") - abort(msg) - } - list(base = base, m = m, hasPost = hasPost) -} - -# Materialise the collected FORMAT specs into the geno matrix list + header -# DataFrame (dropping all-NA specs) and write the VCF via .writeVcfImpl. -# @noRd -.vcfWriteSpecs <- function(base, specs, sn, finalPath, nSnps) { - specs <- keep(specs, .vcfSpecHasValues) - geno <- set_names( - map(specs, .vcfSpecMatrix, nSnps = nSnps), - map_chr(specs, "name") - ) - genoHeader <- DataFrame( - Number = rep("A", length(specs)), - Type = map_chr(specs, "type"), - Description = map_chr(specs, "desc"), - row.names = map_chr(specs, "name") - ) - .writeVcfImpl( - chrom = .vcfCol(base, "chrom", nSnps), - pos = .vcfCol(base, "pos", nSnps), - ref = .vcfCol(base, "A2", nSnps), - alt = .vcfCol(base, "A1", nSnps), - snpIds = .vcfCol(base, "variant_id", nSnps), - geno = geno, - genoHeader = genoHeader, - sampleName = sn, - outputPath = finalPath - ) -} - -# Internal worker: write one (study, context, trait, method) tuple to a -# single VCF. When `splitByContext` / `splitByTrait` is in play the -# output path is decorated with the corresponding tag(s) so multiple -# files don't collide. -# @noRd -.writeFineMappingVcf <- function( - x, - spec, - outputPath, - sampleName, - splitByContext, - splitByTrait -) { - entry <- fineMappingResult( - x, - spec$study, - spec$context, - spec$trait, - spec$method - ) - finalPath <- .decorateOutputPath( - outputPath, - spec, - splitByContext, - splitByTrait - ) - sn <- sampleName %||% - glue( - "{spec$study}|{spec$context %||% '_'}|", - "{spec$trait %||% '_'}|{spec$method}" - ) - body <- .vcfResolveBody(entry, sn) - nSnps <- nrow(body$base) - specs <- c( - .vcfCoreSpecs(body$base, body$m, nSnps), - if (body$hasPost) .vcfPosteriorSpecs(body$base, nSnps) else list() - ) - .vcfWriteSpecs(body$base, specs, sn, finalPath, nSnps) - finalPath -} - -# 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" -# @noRd -.decorateOutputPath <- function( - outputPath, - spec, - splitByContext, - splitByTrait -) { - if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { - return(outputPath) - } - ext <- str_to_lower(tools::file_ext(outputPath)) - composite <- ext == "bgz" || ext == "gz" - base <- if (composite) { - str_remove( - outputPath, - regex("\\.[^.]+\\.(bgz|gz)$", ignore_case = TRUE) - ) - } else { - tools::file_path_sans_ext(outputPath) - } - ext_keep <- str_sub( - outputPath, - str_length(base) + 1L, - str_length(outputPath) - ) - tags <- c( - if ( - isTRUE(splitByContext) && - !is.null(spec$context) && - !is.na(spec$context) && - str_length(spec$context) > 0L - ) { - spec$context - }, - if ( - isTRUE(splitByTrait) && - !is.null(spec$trait) && - !is.na(spec$trait) && - str_length(spec$trait) > 0L - ) { - spec$trait - } - ) - if (length(tags) == 0L) { - return(outputPath) - } - str_c(base, ".", str_flatten(tags, "."), ext_keep) -} - -# Internal implementation shared by all methods -# @noRd -.writeVcfImpl <- function( - chrom, - pos, - ref, - alt, - snpIds, - geno, - genoHeader, - sampleName, - outputPath -) { - # Ensure chromosome names have the "chr" prefix. - if (!all(str_detect(chrom, "^chr"))) { - chrom <- str_c("chr", chrom) - } - gr <- .vcfBuildRanges(chrom, pos, ref, alt, snpIds) - hdr <- .vcfBuildHeader(sampleName, genoHeader, geno) - vcf <- .vcfBuildObject(gr, sampleName, hdr, geno, ref, alt) - .vcfWriteByFormat(vcf, outputPath, chrom) - invisible(outputPath) -} - -# Per-variant rowRanges (end extended to the wider of ref / alt for indels). -# @noRd -.vcfBuildRanges <- function(chrom, pos, ref, alt, snpIds) { - GRanges( - chrom, - IRanges( - start = as.integer(pos), - end = as.integer(pos) + pmax(str_length(ref), str_length(alt)) - 1L, - names = snpIds - ) - ) -} - -# VCF header (VCFv4.2 + the geno header subset to the fields actually present). -# @noRd -.vcfBuildHeader <- function(sampleName, genoHeader, geno) { - hdr <- VariantAnnotation::VCFHeader( - header = DataFrameList( - fileformat = DataFrame(Value = "VCFv4.2", row.names = "fileformat") - ), - sample = sampleName - ) - VariantAnnotation::`geno<-`( - hdr, - value = genoHeader[ - is_in(rownames(genoHeader), names(geno)), - , - drop = FALSE - ] - ) -} - -# Assemble + finalize the VCF object (ref / alt / FILTER, sorted). -# @noRd -.vcfBuildObject <- function(gr, sampleName, hdr, geno, ref, alt) { - vcf <- VariantAnnotation::VCF( - rowRanges = gr, - colData = DataFrame(Samples = sampleName, row.names = sampleName), - exptData = list(header = hdr), - geno = SimpleList(geno) - ) - alleled <- VariantAnnotation::`alt<-`( - VariantAnnotation::`ref<-`(vcf, value = DNAStringSet(ref)), - value = DNAStringSetList(as.list(alt)) - ) - filtered <- VariantAnnotation::`fixed<-`( - alleled, - value = `[[<-`( - VariantAnnotation::fixed(alleled), - "FILTER", - value = "PASS" - ) - ) - sort(filtered) -} - -# Write the VCF in the format implied by the output extension. writeVcf appends -# ".bgz" when index = TRUE, so paths are passed WITHOUT the .bgz/.gz suffix. -# @noRd -.vcfWriteByFormat <- function(vcf, outputPath, chrom) { - ext <- file_ext(outputPath) - if (ext == "bcf") { - .vcfWriteBcf(vcf, outputPath, chrom) - } else if (ext == "gz" || ext == "bgz") { - .vcfWriteBgz(vcf, outputPath) - } else { - VariantAnnotation::writeVcf(vcf, outputPath) - } - invisible(NULL) -} - -# BCF path: write a temporary bgzipped VCF, then convert to BCF via asBcf. -# @noRd -#' @importFrom rlang try_fetch -.vcfWriteBcf <- function(vcf, outputPath, chrom) { - tmpVcfStem <- tempfile(fileext = ".vcf") - tmpVcfBgz <- str_c(tmpVcfStem, ".bgz") - on.exit( - unlink(c(tmpVcfBgz, str_c(tmpVcfBgz, ".tbi")), force = TRUE), - add = TRUE - ) - VariantAnnotation::writeVcf(vcf, tmpVcfStem, index = TRUE) - # asBcf appends ".bcf" to destination, so strip the extension. - # Rsamtools disabled asBcf() (>= 2.26 raises "temporarily disabled"), so - # the bare upstream error is translated into something actionable rather - # than surfacing as an opaque failure from a documented output format. - try_fetch( - asBcf( - tmpVcfBgz, - dictionary = unique(chrom), - destination = str_remove(outputPath, "\\.bcf$") - ), - error = function(cnd) { - msg <- glue( - "writeSumStatsVcf: 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." - ) - abort(msg, parent = cnd) - } - ) -} - -# bgzip / gzip path: writeVcf always creates .bgz; rename to .gz on request. -# @noRd -.vcfWriteBgz <- function(vcf, outputPath) { - vcfStem <- str_remove(outputPath, "\\.(bgz|gz)$") - VariantAnnotation::writeVcf(vcf, vcfStem, index = TRUE) - actualPath <- str_c(vcfStem, ".bgz") - if (actualPath != outputPath && file.exists(actualPath)) { - file.rename(actualPath, outputPath) - tbiActual <- str_c(actualPath, ".tbi") - if (file.exists(tbiActual)) { - file.rename(tbiActual, str_c(outputPath, ".tbi")) - } - } -} - -# ---- map/apply helpers (lambda-free callbacks) --------------------------- - -# FORMAT specs for one cs_ column: a CS index field plus a PUR purity -# field when a matching *_purity column exists. -# @noRd -.vcfCsColSpecs <- function(cc, base) { - cov <- str_remove(cc, "^cs_") - raw <- suppressWarnings(as.integer(str_remove( - as.character(base[[cc]]), - ".*_" - ))) - # 0 = the variant is in no credible set at this coverage. - idx <- replace(raw, is.na(raw), 0L) - csSpec <- .vcfSpec( - str_c("CS", cov), - idx, - "Integer", - glue("Credible-set index at {cov}% coverage (0 = not captured)") - ) - pc <- str_c(cc, "_purity") - if (!is_in(pc, names(base))) { - return(list(csSpec)) - } - pur <- suppressWarnings(as.numeric(base[[pc]])) - purSpec <- .vcfSpec( - str_c("PUR", cov), - pur, - "Float", - glue("Purity (min abs corr) of the {cov}% credible set") - ) - list(csSpec, purSpec) -} - -# The FORMAT spec for one fullFit posterior column (uppercased Float field). -# @noRd -.vcfFullFitColSpec <- function(cc, base) { - v <- suppressWarnings(as.numeric(base[[cc]])) - .vcfSpec( - str_to_upper(cc), - v, - "Float", - glue("Per-credible-set variant statistic ({cc})") - ) -} - -# TRUE when a FORMAT spec has at least one non-NA value (drop all-NA specs). -# @noRd -.vcfSpecHasValues <- function(s) { - any(!is.na(s$values)) -} - -# One FORMAT spec's values reshaped to the nSnps x nSamples geno matrix. -# @noRd -.vcfSpecMatrix <- function(s, nSnps) { - matrix(s$values, nSnps) -} diff --git a/_pkgdown.yml b/_pkgdown.yml index edfb8b7a..2957dc5d 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -297,6 +297,7 @@ reference: - computeCsCorrelation - fsusieAffectedRegions - fsusieCredibleBand + - fsusieTraitEffects - credibleSetSummary - credibleSets - lbf @@ -312,7 +313,10 @@ reference: - variantIds - intersectVariants - resolveWeights - - writeSumStatsVcf + - exportToVcf + - exportToBed + - readFineMappingResult + - blockId - subtitle: "QtlFineMappingResult" contents: @@ -369,7 +373,7 @@ reference: - sumStatsDataFrame - "sumStats,GwasSumStats-method" - varY - - writeSumStatsVcf + - exportToVcf - subtitle: "QtlSumStats" contents: @@ -400,6 +404,9 @@ reference: - variantIds - weights-methods - resolveWeights + - exportToVcf + - exportToBed + - readTwasWeights - subtitle: "TwasWeightsRow" contents: @@ -588,6 +595,7 @@ reference: - parseRegion - regionToDf - asGranges + - genomicOrder - title: "Fine-mapping" desc: > diff --git a/data/mvsusieFineMappingExample.rda b/data/mvsusieFineMappingExample.rda index 6dfbbefa..f635b77b 100644 Binary files a/data/mvsusieFineMappingExample.rda and b/data/mvsusieFineMappingExample.rda differ diff --git a/data/qtlFineMappingExample.rda b/data/qtlFineMappingExample.rda index 025e0d06..23d58881 100644 Binary files a/data/qtlFineMappingExample.rda and b/data/qtlFineMappingExample.rda differ diff --git a/data/qtlFineMappingPairedExample.rda b/data/qtlFineMappingPairedExample.rda index d4cfe98b..2cb0e1b8 100644 Binary files a/data/qtlFineMappingPairedExample.rda and b/data/qtlFineMappingPairedExample.rda differ diff --git a/man/GwasFineMappingResult.Rd b/man/GwasFineMappingResult.Rd index 99a3d45a..19af42fb 100644 --- a/man/GwasFineMappingResult.Rd +++ b/man/GwasFineMappingResult.Rd @@ -10,6 +10,10 @@ GwasFineMappingResult( entry, blockId = NULL, traitPos = NULL, + region = NULL, + dataType = NULL, + dataSource = NULL, + weightStandardized = NULL, ldSketch = NULL ) } @@ -30,6 +34,29 @@ blocks' spans leave gaps.} \code{NULL}), carried forward as provenance; not part of the identity key. \code{NULL} (default) omits the column.} +\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.} + +\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{ldSketch} cannot say which row came from which.} + +\item{weightStandardized}{Optional per-row flag: whether the posterior +effect is on the STANDARDIZED genotype scale. The posterior effect IS the +prediction weight, so it carries the same scale question as a TWAS +weight. \code{\link{fineMappingPipeline}} always passes \code{TRUE}: +it standardizes genotypes before fitting, and the posterior mean is +reported on the scale of the \code{X} the fit was given. The argument +exists for a collection assembled by hand, where only the caller knows.} + \item{ldSketch}{An optional genotype panel (see \code{\link{readGenotypes}}).} } diff --git a/man/QtlFineMappingResult.Rd b/man/QtlFineMappingResult.Rd index 8736c3dc..ed2ccc4c 100644 --- a/man/QtlFineMappingResult.Rd +++ b/man/QtlFineMappingResult.Rd @@ -14,6 +14,10 @@ QtlFineMappingResult( jointContexts = NULL, jointTraits = NULL, traitPos = NULL, + region = NULL, + dataType = NULL, + dataSource = NULL, + weightStandardized = NULL, ldSketch = NULL ) } @@ -46,6 +50,29 @@ shape as \code{jointStudies}.} \code{NULL}), carried forward as provenance; not part of the identity key. \code{NULL} (default) omits the column.} +\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.} + +\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{ldSketch} cannot say which row came from which.} + +\item{weightStandardized}{Optional per-row flag: whether the posterior +effect is on the STANDARDIZED genotype scale. The posterior effect IS the +prediction weight, so it carries the same scale question as a TWAS +weight. \code{\link{fineMappingPipeline}} always passes \code{TRUE}: +it standardizes genotypes before fitting, and the posterior mean is +reported on the scale of the \code{X} the fit was given. The argument +exists for a collection assembled by hand, where only the caller knows.} + \item{ldSketch}{An optional genotype panel (see \code{\link{readGenotypes}}) (the LD reference for RSS-derived fits), or \code{NULL} for individual-level fits.} diff --git a/man/ResidualizationParam.Rd b/man/ResidualizationParam.Rd index bfce5fa0..b07794e7 100644 --- a/man/ResidualizationParam.Rd +++ b/man/ResidualizationParam.Rd @@ -11,6 +11,7 @@ ResidualizationParam( genotypeCovariates = NULL, residualizePhenotype = NULL, residualizeGenotype = NULL, + scaleResiduals = NULL, covariateNaAction = NULL ) } @@ -28,6 +29,15 @@ read as \code{TRUE}.} \item{residualizeGenotype}{Logical. Residualize on the genotype 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.} + \item{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.} diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index 338c0046..f6c03e75 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -14,6 +14,7 @@ TwasWeights( jointContexts = NULL, jointTraits = NULL, traitPos = NULL, + region = NULL, ldSketch = NULL ) } @@ -46,6 +47,12 @@ shape as \code{jointStudies}.} \code{NULL}), carried forward as provenance; not part of the identity key. \code{NULL} (default) omits the column.} +\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.} + \item{ldSketch}{An optional genotype panel (see \code{\link{readGenotypes}}), or \code{NULL} for individual-level fits.} } diff --git a/man/blockId.Rd b/man/blockId.Rd new file mode 100644 index 00000000..a6d53181 --- /dev/null +++ b/man/blockId.Rd @@ -0,0 +1,46 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/RangedTupleList.R +\name{blockId} +\alias{blockId} +\alias{blockId,RangedTupleList-method} +\title{Get The LD Block Identifier} +\usage{ +blockId(x, ...) + +\S4method{blockId}{RangedTupleList}(x, ...) +} +\arguments{ +\item{x}{The object.} + +\item{...}{Reserved for future use.} +} +\value{ +Character, one value per row of \code{x} (\code{NA} where the row + records none). +} +\description{ +Return the LD-block identifier of each row of a collection + that keys its rows by block --- a \code{GwasSumStats}, or a + \code{GwasFineMappingResult} fine-mapped over one. + + Per ROW, like \code{\link{genomicRegion}} and unlike + \code{\link{studyName}} / \code{\link{methodNames}}: a block id is + provenance for a particular fit, not an axis the collection is indexed + 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. +} +\examples{ +data(gwasFineMappingExample, qtlFineMappingExample) +blockId(gwasFineMappingExample) +# A QTL result has no block axis, so one NA per row rather than an error. +blockId(qtlFineMappingExample) +} +\seealso{ +\code{\link{genomicRegion}} for the window that was analysed. +} diff --git a/man/colocboostPipeline.Rd b/man/colocboostPipeline.Rd index d054c457..6b5a047e 100644 --- a/man/colocboostPipeline.Rd +++ b/man/colocboostPipeline.Rd @@ -24,6 +24,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, + residualizationArgs = ResidualizationParam(), methodArgs = ColocboostOptions() ) @@ -56,6 +57,7 @@ colocboostPipeline(qtlData, gwasSumStats = NULL, ...) panelFilterParam = PanelFilterParam(), signalScreenArgs = SignalScreenParam(), alleleFlip = TRUE, + residualizationArgs = ResidualizationParam(), methodArgs = ColocboostOptions() ) } @@ -134,6 +136,17 @@ swaps recognized (flipping z / residualized dosage / LD to a shared coding); when FALSE, match on exact alleles only (names-only), so a ref/alt swap is treated as a distinct variant.} +\item{residualizationArgs}{Covariate residualization settings for +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 +\code{\link{fineMappingPipeline}} and +\code{\link{twasWeightsPipeline}}. \strong{Ignored} on +\code{QtlSumStats} input, which has nothing to residualize.} + \item{methodArgs}{Additional arguments forwarded to \code{colocboost::colocboost}, built with \code{\link{ColocboostOptions}}. Names are checked against that diff --git a/man/exportToBed.Rd b/man/exportToBed.Rd new file mode 100644 index 00000000..37acdf76 --- /dev/null +++ b/man/exportToBed.Rd @@ -0,0 +1,138 @@ +% 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} +\usage{ +exportToBed(x, outputPath, ...) + +\S4method{exportToBed}{list}(x, outputPath, ...) + +\S4method{exportToBed}{FineMappingResultBase}( + x, + outputPath, + schema = c("topLoci", "fsusie"), + signalCutoff = 0.025, + minPurity = NULL, + coverage = NULL, + levels = c("wavelet", "trait"), + columns = NULL, + extraColumns = NULL +) + +\S4method{exportToBed}{TwasWeights}( + x, + outputPath, + coverage = NULL, + columns = NULL, + extraColumns = NULL +) +} +\arguments{ +\item{x}{A \code{FineMappingResult} or \code{TwasWeights} object, or a +\code{list} of either, to combine first.} + +\item{outputPath}{Output path. A \code{.gz} / \code{.bgz} extension selects +bgzip + tabix (via Rsamtools, so no htslib binary is needed); any other +extension writes a plain table.} + +\item{...}{Additional arguments passed to methods.} + +\item{schema}{\code{FineMappingResult} only: which published schema to +write, \code{"topLoci"} (default) or \code{"fsusie"}.} + +\item{signalCutoff}{PIP cutoff passed to \code{\link{topLoci}} +(\code{FineMappingResult}, \code{"topLoci"} schema only). Default 0.025.} + +\item{minPurity}{Optional credible-set purity cutoff passed to +\code{\link{topLoci}} (\code{FineMappingResult}, \code{"topLoci"} schema +only). Default \code{NULL} for no purity filter.} + +\item{coverage}{Which credible-set coverage levels to publish, as +proportions (\code{c(0.95, 0.5)}). \code{NULL} (default) publishes every +level the input carries. Which levels exist is fixed at FIT time by +\code{\link{CredibleSetParam}} and the stored \code{cs_} columns are +read rather than recomputed, so this selects a subset and errors -- +naming what is available -- for a level the fit never computed.} + +\item{levels}{\code{"fsusie"} schema only: which resolution(s) of the +fitted effect to write. fSuSiE carries the same effect twice -- +\code{"wavelet"}, the curve on the fit's own grid +(\code{\link{fsusieCredibleBand}}), and \code{"trait"}, that curve +reinterpolated onto the positions of the traits the fit ran over +(\code{\link{fsusieTraitEffects}}). They are complementary, so both are +written by default; naming one drops the other's columns, leaving a strict +subset of the full table.} + +\item{columns}{Which of the SOURCE view's own variant-level columns to +append after the published schema. \code{NULL} (default) appends none; +\code{"all"} appends every column the view carries that the schema does +not already write; a character vector appends exactly those. The +published columns always lead, so adding to them never moves an existing +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.} + +\item{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 +legacy top-loci BED's \code{block_id}, parsed from the source filename, +is the motivating case. Names that collide with a published column are an +error rather than a silent overwrite.} +} +\value{ +\code{outputPath}, 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. +} +\details{ +A \code{TwasWeights} writes one table, a row per (variant, weight column). +A \code{FineMappingResult} offers two, selected with \code{schema}: +\describe{ + \item{\code{"topLoci"}}{(default) the posterior view joined to the + marginal one, a row per (variant, context).} + \item{\code{"fsusie"}}{the functional view, a row per (context, + credible set), carrying the fitted curve at both resolutions + \code{levels} selects.} +} + +Every table identifies the fit a row came from -- \code{study_ID}, +\code{gene_ID}, \code{event_ID} and (where it spans methods) +\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 +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. +} +\examples{ +data(qtlFineMappingExample) +exportToBed(qtlFineMappingExample, tempfile(fileext = ".bed")) +exportToBed( + qtlFineMappingExample, tempfile(fileext = ".bed"), + schema = "topLoci", columns = "all" +) +data(twasWeightsExample) +exportToBed(twasWeightsExample, tempfile(fileext = ".bed")) +} +\seealso{ +\code{\link{exportToVcf}}, \code{\link{genomicOrder}} +} diff --git a/man/exportToVcf.Rd b/man/exportToVcf.Rd new file mode 100644 index 00000000..437eb79b --- /dev/null +++ b/man/exportToVcf.Rd @@ -0,0 +1,114 @@ +% 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{FineMappingResult} or +\code{TwasWeights} object, or a \code{list} of \code{FineMappingResult} +/ \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{\code{FineMappingResult}}{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/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index aad0192a..02d29fbf 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -33,7 +33,8 @@ fineMappingPipeline(data, ...) dataDrivenPriorWeightsCutoff = 1e-10, naAction = c("drop", "impute"), verbose = 1, - fitRetention = c("slim", "full") + fitRetention = c("slim", "full"), + dataType = NULL ) \S4method{fineMappingPipeline}{MultiStudyQtlDataset}( @@ -61,7 +62,8 @@ fineMappingPipeline(data, ...) seed = NULL, naAction = c("drop", "impute"), verbose = 1, - fitRetention = c("slim", "full") + fitRetention = c("slim", "full"), + dataType = NULL ) \S4method{fineMappingPipeline}{QtlSumStats}( @@ -80,7 +82,8 @@ fineMappingPipeline(data, ...) susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam() + residualizationArgs = ResidualizationParam(), + dataType = NULL ) \S4method{fineMappingPipeline}{GwasSumStats}( @@ -94,7 +97,8 @@ fineMappingPipeline(data, ...) susieRssParam = SusieRssParam(), panelFilterParam = PanelFilterParam(), crossValidationArgs = CrossValidationParam(), - residualizationArgs = ResidualizationParam() + residualizationArgs = ResidualizationParam(), + dataType = NULL ) } \arguments{ @@ -285,6 +289,12 @@ matrices. The per-variant \code{topLoci} table is fully populated either way --- its per-credible-set columns are governed by \code{credibleSet}'s \code{perCsColumns}, not by this.} +\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.} + \item{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.} @@ -464,6 +474,29 @@ deliberately not ported here: rare variant would need. } +\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{\link{colocboostPipeline}}. An RSS fit needs nothing done: its + likelihood is written in standardized units already. + + It is what makes weights comparable across methods. Measured through + pecotmr's own entry points, every TWAS method returns coefficients on the + scale of the \code{X} it was given, and the DPR samplers are not even + scale-equivariant --- a uniform rescale of \code{X} changes their fit + rather than just its units. One input scale removes the question, and it + is the scale the LD correlations and z-scores behind a TWAS Z are already + on. +} + \examples{ data(qtlDatasetExample) fineMappingPipeline(qtlDatasetExample, methods = "susie", cisWindow = 1e6) diff --git a/man/fsusieCredibleBand.Rd b/man/fsusieCredibleBand.Rd index b1b371c8..a1e29d90 100644 --- a/man/fsusieCredibleBand.Rd +++ b/man/fsusieCredibleBand.Rd @@ -15,8 +15,10 @@ fsusieCredibleBand(x, ...) \item{...}{Ignored.} } \value{ -A long \code{tibble}: \code{cs, chrom, pos, effect, lower, upper} - (the collection method additionally carries the entry identity columns). +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). } \description{ For a functional-SuSiE (\code{fsusieR::susiF}) fine-mapping entry, returns @@ -32,5 +34,6 @@ data(fsusieFineMappingExample) fsusieCredibleBand(fsusieFineMappingExample) } \seealso{ -\code{\link{fsusieAffectedRegions}} +\code{\link{fsusieTraitEffects}}, + \code{\link{fsusieAffectedRegions}} } diff --git a/man/fsusieTraitEffects.Rd b/man/fsusieTraitEffects.Rd new file mode 100644 index 00000000..c3fe3ac3 --- /dev/null +++ b/man/fsusieTraitEffects.Rd @@ -0,0 +1,42 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{fsusieTraitEffects} +\alias{fsusieTraitEffects} +\alias{fsusieTraitEffects,FineMappingResultBase-method} +\title{fSuSiE effect at each joint trait} +\usage{ +fsusieTraitEffects(x, ...) + +\S4method{fsusieTraitEffects}{FineMappingResultBase}(x) +} +\arguments{ +\item{x}{A \code{FineMappingRow} or \code{FineMappingResultBase}.} + +\item{...}{Ignored.} +} +\value{ +A long \code{tibble}: \code{cs, chrom, jointTrait, traitPos, + effect} (the collection method additionally carries the entry identity + columns). +} +\description{ +The fitted effect curve evaluated AT the traits the functional fit was run +over, one row per (credible set, trait). The curve itself lives on a wavelet +grid (\code{\link{fsusieCredibleBand}}); the traits sit at arbitrary +positions between grid points, so the effect is linearly interpolated with +constant extrapolation past the ends. +} +\details{ +This is the view that pairs a trait's NAME with its position: the names come +from the row's \code{jointTraits} column and the positions from the fit, +index-aligned because both describe the same joint group. Returns zero rows +when the functional fields are absent. +} +\examples{ +data(fsusieFineMappingExample) +fsusieTraitEffects(fsusieFineMappingExample) +} +\seealso{ +\code{\link{fsusieCredibleBand}}, + \code{\link{fsusieAffectedRegions}} +} diff --git a/man/genomicOrder.Rd b/man/genomicOrder.Rd new file mode 100644 index 00000000..a690f19c --- /dev/null +++ b/man/genomicOrder.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resultWriters.R +\name{genomicOrder} +\alias{genomicOrder} +\title{Order rows by genomic position, with chromosomes sorted naturally} +\usage{ +genomicOrder(chrom, start, end = NULL) +} +\arguments{ +\item{chrom}{Chromosome labels. A leading \code{"chr"} is optional and is +ignored for ordering, so \code{"chr2"} and \code{"2"} sort alike.} + +\item{start}{Start positions; coerced to numeric, non-numeric entries sort +last within their chromosome.} + +\item{end}{Optional second position key, used only to break ties on +\code{start} (a half-open BED's end column). Ignored when it is not +numeric, so a table whose third column is not a position (an allele, say) +can pass it harmlessly.} +} +\value{ +An integer permutation, as from \code{order()}. +} +\description{ +Returns the permutation that puts rows in genomic order: chromosomes +1..22 numerically, then the non-numeric contigs (X, Y, MT, ...) +alphabetically after all of them, and positions numerically within a +chromosome. A plain character sort puts chr10 before chr2, which is why +published tables need this. +} +\details{ +Shared by every pecotmr writer and by the pipeline wrappers that merge +per-region tables, so one definition of "genomic order" covers both. +} +\examples{ +genomicOrder(c("chr10", "chr2", "chrX", "chr2"), c(5, 90, 1, 10)) +} diff --git a/man/genomicRegion.Rd b/man/genomicRegion.Rd index e8f89e0f..4d730306 100644 --- a/man/genomicRegion.Rd +++ b/man/genomicRegion.Rd @@ -4,7 +4,7 @@ \alias{genomicRegion} \alias{genomicRegion,FineMappingResultBase-method} \alias{genomicRegion,TwasWeights-method} -\title{Get Per-Row Genomic Regions} +\title{Get Per-Row Analysis Windows} \usage{ genomicRegion(x, ...) @@ -19,16 +19,34 @@ genomicRegion(x, ...) } \value{ A \code{GRanges} with one range per row of \code{x}, or an empty - \code{GRanges} when the collection carries no region provenance. + \code{GRanges} when the collection has no rows. } \description{ -Return the genomic anchor of each row of a per-tuple collection - as a \code{GRanges} with one range per row -- the trait's own region for a - \code{TwasWeights}, or the fine-mapping window for a - \code{FineMappingResult}. This is location provenance (e.g. for cTWAS - LD-block placement). +Return the genomic interval each row was analysed over, as a + \code{GRanges} with one range per row -- the trait's own region for a + \code{TwasWeights}, and for a \code{FineMappingResult} the window the fit + 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). + + 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 + \code{chr22:10000000-18000000} may contain variants spanning only + \code{chr22:10414272-16916492}. The window is stored because it cannot be + 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 + still produced by a fit over the original window. Use \code{range(x)} when + you want the current content instead. + + Collections built before the window was recorded fall back to the derived + span, so the accessor always returns a range. } \examples{ data(qtlFineMappingExample) genomicRegion(qtlFineMappingExample) } +\seealso{ +\code{\link{traitPosition}} for the trait's own coordinates. +} diff --git a/man/overlapTopLoci.Rd b/man/overlapTopLoci.Rd index 82182ef0..e78c0e9b 100644 --- a/man/overlapTopLoci.Rd +++ b/man/overlapTopLoci.Rd @@ -30,8 +30,8 @@ Intersect the top-loci tables of a \code{QtlFineMappingResult} and a \code{GwasFineMappingResult} on shared variants, matched with pecotmr's allele-aware \code{matchVariants} (handling strand flips / ref-alt swaps rather than naive id equality). The GWAS side is harmonized to the QTL -orientation: its signed effect columns (\code{beta}, \code{z}, -\code{conditional_effect}) are sign-flipped and its effect-allele frequency +orientation: its signed effect columns (\code{posterior_effect}, +\code{beta}, \code{z}) are sign-flipped and its effect-allele frequency (\code{af}) is complemented wherever a swap occurred. The result keeps the variant key columns once (from the QTL, the reference orientation) and prefixes every other column \code{qtl_} / \code{gwas_}. A variant shared diff --git a/man/parseRegion.Rd b/man/parseRegion.Rd index 6814441b..b011a737 100644 --- a/man/parseRegion.Rd +++ b/man/parseRegion.Rd @@ -20,4 +20,5 @@ non-scalar input is returned unchanged. } \examples{ parseRegion("chr1:1000000-2000000") +parseRegion("chr1_1000000_2000000") } diff --git a/man/readFineMappingResult.Rd b/man/readFineMappingResult.Rd new file mode 100644 index 00000000..644c15c4 --- /dev/null +++ b/man/readFineMappingResult.Rd @@ -0,0 +1,121 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resultReaders.R +\name{readFineMappingResult} +\alias{readFineMappingResult} +\title{Read A Published Fine-Mapping Result} +\usage{ +readFineMappingResult( + path, + region = NULL, + format = c("auto", "bed", "vcf"), + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + dataType = NULL, + weightStandardized = NULL, + sampleSelect = NULL, + priorVariance = NULL +) +} +\arguments{ +\item{path}{Path to the published file. Bgzipped and tabix-indexed files +can be read by region.} + +\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{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.} + +\item{studyName, context, trait, method}{Identity values for a file that did +not record them. Each FILLS IN the corresponding column when the file +lacks it; a value that disagrees with what the file does record is an +error rather than a silent override.} + +\item{dataType}{Optional assay / modality label, same fill-in rule.} + +\item{weightStandardized}{Whether the published posterior effect +(\code{WGT}) is on the standardized genotype scale. Required when the +file publishes \code{WGT} without \code{weight_standardized}: the scale +is not recoverable from the weights, since converting between the two +rescales every variant by its own allele-frequency-dependent factor.} + +\item{sampleSelect}{For a multi-sample VCF, which samples to read. Each +sample is one fitted model. Defaults to all of them.} + +\item{priorVariance}{Opt-in Wakefield prior variance (\code{W}) for +deriving per-variant log Bayes factors from z when the file has no +\code{LBF}. These are an approximation under a prior you chose, not +susie's \code{lbf_variable}, so nothing derives them unasked.} +} +\value{ +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. + + A merged table holding several \code{(study, context, trait, method)} + tuples reads back as a multi-row collection, one row per tuple. Which + class is returned follows the axes the file has: a result with a context + or a trait is a QTL result, one without is a GWAS result. +} +\section{What is required, and what is not}{ + + Only what the class cannot exist without: variant ids that encode + coordinates (or the \code{#chr} / \code{start} / \code{end} / \code{REF} + / \code{ALT} columns to build them from) and a \code{PIP} column. + Everything else is optional, because each consumer needs a different few + columns -- Mendelian randomization the marginal effect and its standard + error, colocalization the log Bayes factors -- and a file converted from + another tool will have some and not others. A consumer reached without + what it needs says which column is missing. + + The fit itself is not published. A VCF's \code{##SAMPLE} header records + the two per-effect quantities that no per-variant column could hold -- + the prior variances \code{V} and the credible sets' \code{cs_index} -- + and those are restored as a partial \code{susieFit}; a BED carries + neither. Anything needing the posterior matrices (colocalization's LBF + path) wants the \code{LBF} columns, not the fit. +} + +\section{What a round trip changes}{ + + Every published quantity comes back identical, in either format. Three + things are not identities: + \itemize{ + \item \code{exportToBed()} 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. + \item Credible-set membership comes back as \code{NA} where the fit + recorded the \code{"_0"} not-captured sentinel. Both formats + publish an integer index, and \code{NA} is what every reader of the + column already treats as "in no credible set". + \item \code{data_source} and \code{weight_standardized} are + populated on the way back -- the writer derives the first and the + reader is told the second -- where a fit predating them left them + empty. + } +} + +\examples{ +data(qtlFineMappingExample) +path <- file.path(tempdir(), "top_loci.bed") +exportToBed(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{readTwasWeights}} +} diff --git a/man/readTwasWeights.Rd b/man/readTwasWeights.Rd new file mode 100644 index 00000000..54f845e8 --- /dev/null +++ b/man/readTwasWeights.Rd @@ -0,0 +1,85 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/resultReaders.R +\name{readTwasWeights} +\alias{readTwasWeights} +\title{Read Published TWAS Weights} +\usage{ +readTwasWeights( + path, + region = NULL, + format = c("auto", "bed", "vcf"), + studyName = NULL, + context = NULL, + trait = NULL, + method = NULL, + dataType = NULL, + weightStandardized = NULL, + sampleSelect = NULL +) +} +\arguments{ +\item{path}{Path to the published file. Bgzipped and tabix-indexed files +can be read by region.} + +\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{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.} + +\item{studyName, context, trait, method}{Identity values for a file that did +not record them. Each FILLS IN the corresponding column when the file +lacks it; a value that disagrees with what the file does record is an +error rather than a silent override.} + +\item{dataType}{Optional assay / modality label, same fill-in rule.} + +\item{weightStandardized}{Whether the published weights are on the +standardized genotype scale. Required when the file does not record it: +the scale is not recoverable from the weights themselves.} + +\item{sampleSelect}{For a multi-sample VCF, which samples to read. Each +sample is one fitted model. Defaults to all of them.} +} +\value{ +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. + + A merged table reads back as a multi-row collection, one row per + \code{(study, context, trait, method)} tuple. A fitted model whose + weights were a MATRIX -- a joint fit, one column per member -- was + published as one block per member with \code{trait} naming it, so it + reads back as one row per member with \code{joint_traits} keeping the + membership. The weights are identical either way; only the packing + differs. +} +\section{What is required, and what is not}{ + + Variant ids that encode coordinates (or the columns to build them from) + and a \code{WGT} column -- a weight is the whole content of a + \code{TwasWeights}. The four identity axes must be recorded or supplied, + because the collection is keyed by them. Everything else is optional and + carried through if present. + + Cross-validation metrics are never published (they describe a model + scored on held-out folds, which is not per-variant and not + data-secure to express per sample), so a read-back collection has no + \code{cvResult} and no fitted models. +} + +\examples{ +data(twasWeightsExample) +path <- file.path(tempdir(), "weights.bed") +exportToBed(twasWeightsExample, path) +readTwasWeights(path) +} +\seealso{ +\code{\link{exportToBed}}, \code{\link{readFineMappingResult}} +} diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 87b1fe72..a63e090d 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -311,6 +311,29 @@ same shared partition. RAISS will impute. } +\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. + + 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 + --- exactly so for glmnet / ncvreg / L0Learn / mr.ash / the Bayesian + alphabet and for \code{susieWeights()} --- while the DPR samplers are + not scale-equivariant at all, so a uniform rescale of \code{X} changes + their fit and not merely its units. The chosen scale is also the one the + LD correlations and z-scores behind a TWAS Z already use. A + summary-statistics fit needs nothing done. + + \code{\link{learnTwasWeights}} still takes \code{weightStandardized}: + there the caller supplies \code{X} themselves, so only they can say. +} + \examples{ data(qtlDatasetExample) twasWeightsPipeline(qtlDatasetExample, methods = "lasso", cisWindow = 1e6) diff --git a/man/writeSumStatsVcf.Rd b/man/writeSumStatsVcf.Rd deleted file mode 100644 index 484012c5..00000000 --- a/man/writeSumStatsVcf.Rd +++ /dev/null @@ -1,71 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/vcfWriter.R -\name{writeSumStatsVcf} -\alias{writeSumStatsVcf} -\alias{writeSumStatsVcf,GwasSumStats-method} -\alias{writeSumStatsVcf,FineMappingResultBase-method} -\title{Write summary statistics or fine-mapping results to VCF/BCF} -\usage{ -writeSumStatsVcf(x, outputPath, sampleName = NULL, ...) - -\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, studyName = NULL) - -\S4method{writeSumStatsVcf}{FineMappingResultBase}( - x, - outputPath, - sampleName = NULL, - studyName = NULL, - context = NULL, - trait = NULL, - method = NULL, - splitByContext = FALSE, - splitByTrait = FALSE -) -} -\arguments{ -\item{x}{Input data: a \code{GwasSumStats} object, a \code{FineMappingResult} -object, or a data.frame with columns \code{chrom}, \code{pos}, \code{ref}, -\code{alt}.} - -\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 for the VCF sample column (default: trait name or -method name from the S4 object).} - -\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 to the written file. -} -\description{ -Creates a VCF object from GWAS summary statistics or fine-mapping results and -writes it to disk via VariantAnnotation and Rsamtools. 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. -} -\examples{ -data(gwasSumStatsS4Example) -writeSumStatsVcf( - gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) -} diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 047e2810..e687c5fe 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -848,3 +848,53 @@ test_that("seqinfo is left alone when the source carries none", { ) expect_identical(pecotmr:::.rtlRestoreSeqinfo(grl, empty), grl) }) + +# --------------------------------------------------------------------------- +# blockId(): per-ROW, on every collection flavour +# +# `blockId` was a constructor argument and a published column with no +# accessor, so reading it back meant reaching into mcols(). One method on the +# shared base rather than one per flavour: every collection that keys rows by +# LD block stores it in the same column, and the ones with no block axis want +# the same NA-padded answer. +# --------------------------------------------------------------------------- + +test_that("blockId is one value per row, NA where the row records none", { + data(gwasFineMappingExample, qtlFineMappingExample, envir = environment()) + gwas <- blockId(gwasFineMappingExample) + expect_length(gwas, nrow(gwasFineMappingExample)) + expect_false(anyNA(gwas)) + # Per ROW, not unique() like studyName/methodNames: a block id labels one + # fit, so the vector has to stay alignable with the rows. + expect_type(gwas, "character") + # A QTL result has no block axis at all, so NA per row rather than an + # error -- code handling both flavours needs no class test. + qtl <- blockId(qtlFineMappingExample) + expect_length(qtl, nrow(qtlFineMappingExample)) + expect_true(all(is.na(qtl))) +}) + +test_that("blockId holds the length contract on every flavour", { + data(gwasSumStatsS4Example, twasWeightsExample, envir = environment()) + for (x in list(gwasSumStatsS4Example, twasWeightsExample)) { + expect_length(blockId(x), nrow(x)) + } +}) + +test_that("blockId reads the recorded value, not the variants' span", { + # The point of storing it: the id keys the external block manifest, so it + # carries the true block BOUNDARIES, while range(x) is only the span of + # the variants that survived QC. + 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) + res <- GwasFineMappingResult( + studyName = "s", + method = "susie", + entry = list(row), + blockId = "chr1_1_1000000" + ) + expect_equal(blockId(res), "chr1_1_1000000") +}) diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index d7597f7d..65d738c8 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -1202,7 +1202,10 @@ test_that(".cipComputeMr: IVW Wald-ratio over PIP-passing instruments", { se = rep(0.05, 4), stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) res <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4)), c(2, -1.5, 1, 1.8)), @@ -1227,7 +1230,10 @@ test_that(".cipComputeMr: the exposure standardizes when maf/N are absent", { se = 0.01, stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) g <- .cip_gwasDf("chr1:100:A:G", 2) noScale <- g[, setdiff(names(g), c("N", "maf"))] res <- pecotmr:::.cipComputeMr(NULL, noScale, pipCutoff = 0.5) @@ -1282,7 +1288,10 @@ test_that(".cipComputeMr matches across a chr-prefix difference (tuple match)", se = c(0.05, 0.05), stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) # GWAS carries the same variants without the "chr" prefix. g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) res <- pecotmr:::.cipComputeMr(NULL, g, pipCutoff = 0.5) @@ -1298,7 +1307,10 @@ test_that(".cipComputeMr includes an allele-swapped GWAS variant and flips the s se = 0.05, stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) rSame <- pecotmr:::.cipComputeMr( NULL, .cip_gwasDf("chr1:100:A:G", z = 2.0), @@ -1323,7 +1335,10 @@ test_that(".cipComputeMr with alleleFlip = FALSE drops an allele-swapped GWAS va se = 0.05, stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) # GWAS variant is the ref/alt swap; with flipping disabled it is not matched. rSwap <- pecotmr:::.cipComputeMr( NULL, @@ -1344,7 +1359,10 @@ test_that(".cipComputeMrCsAware matches across a chr-prefix difference", { se = c(0.05, 0.05), stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) g <- .cip_gwasDf(c("1:100:A:G", "1:200:A:G"), z = c(2, 1.5)) res <- pecotmr:::.cipComputeMrCsAware(NULL, g, cpipCutoff = 0.5) expect_equal(res$nCs, 1L) @@ -1368,7 +1386,7 @@ test_that(".cipComputeTwasZ reconciles a chr-prefix mismatch (previously dropped expect_true(is.finite(res$Z)) }) -test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero-beta", { +test_that(".cipComputeMr: NA on empty / no-IV / no-overlap / zero-beta", { g <- .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4))) isNa <- function(r) { expect_true(is.na(r$waldRatio)) @@ -1379,17 +1397,6 @@ test_that(".cipComputeMr: NA on empty / missing-col / no-IV / no-overlap / zero- .package = "pecotmr" ) isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) # empty - local_mocked_bindings( - .cipTopLociTable = function(x) { - # no beta/se - data.frame( - variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), - pip = rep(0.9, 4) - ) - }, - .package = "pecotmr" - ) - isNa(pecotmr:::.cipComputeMr(NULL, g, 0.5)) local_mocked_bindings( .cipTopLociTable = function(x) { # none pass @@ -1440,7 +1447,10 @@ test_that(".cipComputeMrCsAware: CS-aware composite Wald + heterogeneity", { se = rep(0.05, 4), stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) res <- pecotmr:::.cipComputeMrCsAware( NULL, .cip_gwasDf( @@ -1463,7 +1473,10 @@ test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback" se = rep(0.05, 2), stringsAsFactors = FALSE ) - local_mocked_bindings(.cipTopLociTable = function(x) tl, .package = "pecotmr") + local_mocked_bindings( + .cipTopLociTable = function(x) tl, + .package = "pecotmr" + ) res <- pecotmr:::.cipComputeMrCsAware( NULL, .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:2)), c(2, -1.5)), @@ -1472,27 +1485,55 @@ test_that(".cipComputeMrCsAware: credible-set column found via the ^cs fallback" expect_true(is.finite(res$waldRatio)) # cs_0.95 via grep("^cs") }) -test_that(".cipComputeMrCsAware: naResult on empty / missing-col / no-CS / no-overlap / low-cpip", { +test_that("the MR paths abort naming the exposure columns they lack", { g <- .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4))) - isNa <- function(r) expect_true(is.na(r$waldRatio)) local_mocked_bindings( - .cipTopLociTable = function(x, ...) data.frame(), + .cipTopLociTable = function(x, ...) { + data.frame( + variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), + pip = rep(0.9, 4) + ) + }, .package = "pecotmr" ) - isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) # empty + # Absent beta/se is a property of the whole table, so it would fail + # identically for every tuple -- it is named, not silently skipped. + expect_error( + pecotmr:::.cipComputeMr(NULL, g, 0.5), + "Wald-ratio path needs pip, beta, se.*has no beta, se" + ) + expect_error( + pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5), + "credible-set-aware path needs.*has no beta, se, cs\\." + ) + # A table carrying everything but `cs` is usable for the Wald ratio and + # only the CS-aware path objects. local_mocked_bindings( - .cipTopLociTable = function(x) { - # no pip col + .cipTopLociTable = function(x, ...) { data.frame( variant_id = sprintf("chr1:%d:A:G", 100L * (1:4)), - cs = rep(1L, 4), + pip = rep(0.9, 4), beta = rep(0.2, 4), se = rep(0.05, 4) ) }, .package = "pecotmr" ) - isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) + expect_true(is.finite(pecotmr:::.cipComputeMr(NULL, g, 0.5)$waldRatio)) + expect_error( + pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5), + "this result has no cs\\." + ) +}) + +test_that(".cipComputeMrCsAware: naResult on empty / no-CS / no-overlap / low-cpip", { + g <- .cip_gwasDf(sprintf("chr1:%d:A:G", 100L * (1:4))) + isNa <- function(r) expect_true(is.na(r$waldRatio)) + local_mocked_bindings( + .cipTopLociTable = function(x, ...) data.frame(), + .package = "pecotmr" + ) + isNa(pecotmr:::.cipComputeMrCsAware(NULL, g, 0.5)) # empty local_mocked_bindings( .cipTopLociTable = function(x) { # cs all 0 diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 837a508e..361e76ad 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -165,7 +165,11 @@ context("colocPipeline") # The enrichment lookup takes each side's identity list, as the scoring loop # builds it. -.cp_side <- function(studyName, context = NA_character_, trait = NA_character_) { +.cp_side <- function( + studyName, + context = NA_character_, + trait = NA_character_ +) { list(study = studyName, context = context, trait = trait) } @@ -517,14 +521,14 @@ test_that(".colocExtractLbfFromEntry: entry without trimmedFit returns NULL with stringsAsFactors = FALSE ) ) - expect_warning( - out <- pecotmr:::.colocExtractLbfFromEntry( - e, - ColocLbfFilterParam() - ), - "has no trimmedFit" + # An absent fit means an absent LBF, and coloc.bf_bf has nothing to score. + # That is a refusal, not a skip: warning per tuple produced an empty + # result that read as "no colocalization" rather than "this input cannot + # be colocalized". + expect_error( + pecotmr:::.colocExtractLbfFromEntry(e, ColocLbfFilterParam()), + "no retained fit" ) - expect_null(out) }) test_that(".colocExtractLbfFromEntry: filterLbfCs subsets by cs_index", { @@ -1080,15 +1084,15 @@ test_that(".colocExtractLbfFromEntry: stacks nested fSuSiE lBF (fit[[1]] path)", expect_equal(nrow(out$lbf), 2L) }) -test_that(".colocExtractLbfFromEntry: warns + NULL when fit carries no LBF slot", { - fit <- list(notLbf = list(a = 1)) # fit[[1]] is a list -> $ access is safe +test_that(".colocExtractLbfFromEntry: refuses a fit carrying no LBF slot", { + fit <- list(notLbf = list(a = 1)) e <- fineMappingRow( variantIds = "chr1:100:A:G", susieFit = fit, topLoci = .cp_tl("chr1:100:A:G") ) - expect_warning( - out <- pecotmr:::.colocExtractLbfFromEntry( + expect_error( + pecotmr:::.colocExtractLbfFromEntry( e, lbfFilterArgs = ColocLbfFilterParam( filterLbfCs = FALSE, @@ -1096,12 +1100,24 @@ test_that(".colocExtractLbfFromEntry: warns + NULL when fit carries no LBF slot" concentration = 0.5 ) ), - "no lbf_variable" + "no per-effect LBF matrix" ) - expect_null(out) }) -test_that(".colocExtractLbfFromEntry: warns + NULL on an empty LBF matrix", { +test_that(".colocExtractLbfFromEntry: reads a bare fSuSiE lBF list", { + # The shape an fSuSiE fit actually carries. coloc used to look only for + # lbf_variable / fsusie_result$lBF and skipped these silently, while + # lbf() read them fine -- the two extractors had drifted apart. + data(fsusieFineMappingExample) + fit <- susieFit(fsusieFineMappingExample) + expect_type(fit$lBF, "list") + m <- pecotmr:::.colocLbfMatrix(fit, "probe") + expect_true(is.matrix(m)) + expect_identical(nrow(m), length(fit$lBF)) + expect_identical(m, pecotmr:::.asLbfMatrix(fit)) +}) + +test_that(".colocExtractLbfFromEntry: refuses an empty LBF matrix", { fit <- list( lbf_variable = matrix( numeric(0), @@ -1115,8 +1131,8 @@ test_that(".colocExtractLbfFromEntry: warns + NULL on an empty LBF matrix", { susieFit = fit, topLoci = .cp_tl(sprintf("chr1:%d:A:G", 100L * (1:3))) ) - expect_warning( - out <- pecotmr:::.colocExtractLbfFromEntry( + expect_error( + pecotmr:::.colocExtractLbfFromEntry( e, lbfFilterArgs = ColocLbfFilterParam( filterLbfCs = FALSE, @@ -1124,9 +1140,8 @@ test_that(".colocExtractLbfFromEntry: warns + NULL on an empty LBF matrix", { concentration = 0.5 ) ), - "LBF matrix is empty" + "no per-effect LBF matrix" ) - expect_null(out) }) test_that(".colocExtractLbfFromEntry: secondary CS filter subsets rows", { diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index 20cae95c..e467dddb 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -1513,3 +1513,51 @@ test_that(".cbAppendGwasPairs disambiguates a colliding study key", { test_that(".cbConcat answers an empty list for no pieces", { expect_identical(pecotmr:::.cbConcat(list()), list()) }) + +test_that("colocboostPipeline forwards residualizationArgs to both sides", { + # It accepted no bundle at all, so it ran on the dataset's own settings + # with no per-call say -- unlike fineMappingPipeline() and + # twasWeightsPipeline(). Both SIDES matter here: colocboost consumes X and + # 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 + seen <- new.env(parent = emptyenv()) + note <- function(which, ra) { + assign( + which, + c( + get0(which, seen, ifnotfound = character(0)), + as.character(ra$scaleResiduals %||% "unset") + ), + envir = seen + ) + } + local_mocked_bindings( + residualizedGenotypes = function( + x, + ..., + residualizationArgs = ResidualizationParam() + ) { + note("geno", residualizationArgs) + origG(x, ..., residualizationArgs = residualizationArgs) + }, + residualizedPhenotypes = function( + x, + ..., + residualizationArgs = ResidualizationParam() + ) { + note("pheno", residualizationArgs) + origP(x, ..., residualizationArgs = residualizationArgs) + }, + .package = "pecotmr" + ) + suppressWarnings(suppressMessages(colocboostPipeline( + qtlDatasetExample, + cisWindow = 1e6, + residualizationArgs = ResidualizationParam(scaleResiduals = FALSE) + ))) + expect_equal(unique(get("geno", envir = seen)), "FALSE") + expect_equal(unique(get("pheno", envir = seen)), "FALSE") +}) diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index 48002ace..878667f1 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -474,7 +474,10 @@ test_that(".fmResolveSusieChain: keeps susieInf when explicitly requested", { }) test_that(".fmResolveSusieChain: no chain when addSusieInf=FALSE", { - res <- pecotmr:::.fmResolveSusieChain(c("susie"), initializeWithSusieInf = FALSE) + res <- pecotmr:::.fmResolveSusieChain( + c("susie"), + initializeWithSusieInf = FALSE + ) expect_false(res$chainSusie) expect_false(res$runInf) }) @@ -701,8 +704,16 @@ test_that(".rbindFineMappingResult: concatenates two GwasFineMappingResult colle stringsAsFactors = FALSE ) ) - a <- GwasFineMappingResult(studyName = "g1", method = "susie", entry = list(e)) - b <- GwasFineMappingResult(studyName = "g2", method = "susie", entry = list(e)) + a <- GwasFineMappingResult( + studyName = "g1", + method = "susie", + entry = list(e) + ) + b <- GwasFineMappingResult( + studyName = "g2", + method = "susie", + entry = list(e) + ) out <- pecotmr:::.rbindFineMappingResult(a, b) expect_s4_class(out, "GwasFineMappingResult") expect_equal(nrow(out), 2L) @@ -2143,7 +2154,10 @@ test_that("fineMappingPipeline(MSQD): L / Lgreedy reach the per-study fit", { methods = "susie", cisWindow = 1000L, initializeWithSusieInf = FALSE, - credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L) + credibleSetParam = CredibleSetParam( + maxNumSingleEffects = 4L, + maxNumSingleEffectsGreedy = 2L + ) ) ) # The multi-study method had no L / Lgreedy formals of its own before the @@ -2717,7 +2731,10 @@ test_that("fineMappingPipeline(QtlSumStats): top-level L / Lgreedy reach the sus ss, methods = "susie", initializeWithSusieInf = FALSE, - credibleSetParam = CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L) + credibleSetParam = CredibleSetParam( + maxNumSingleEffects = 4L, + maxNumSingleEffectsGreedy = 2L + ) ) ) # QtlDataset and GwasSumStats have always taken these; QtlSumStats did not, @@ -5200,7 +5217,10 @@ test_that("CredibleSetParam validity accepts every legitimate construction", { "CredibleSetParam" ) expect_s4_class( - CredibleSetParam(maxNumSingleEffects = 4L, maxNumSingleEffectsGreedy = 2L), + CredibleSetParam( + maxNumSingleEffects = 4L, + maxNumSingleEffectsGreedy = 2L + ), "CredibleSetParam" ) expect_s4_class( @@ -5228,8 +5248,14 @@ test_that("CredibleSetParam validity catches range and length errors", { CredibleSetParam(secondaryCoverage = c(0.7, 3)), "secondaryCoverage" ) - expect_error(CredibleSetParam(maxNumSingleEffects = 0), "maxNumSingleEffects") - expect_error(CredibleSetParam(maxNumSingleEffects = 2.5), "maxNumSingleEffects") + expect_error( + CredibleSetParam(maxNumSingleEffects = 0), + "maxNumSingleEffects" + ) + expect_error( + CredibleSetParam(maxNumSingleEffects = 2.5), + "maxNumSingleEffects" + ) expect_error( CredibleSetParam(maxNumSingleEffectsGreedy = 0), "maxNumSingleEffectsGreedy" @@ -5311,3 +5337,281 @@ test_that(".fmOwnedEngineArgs owns nothing for an unknown engine", { character(0) ) }) + +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") + # An explicit block range wins untouched. + expect_identical( + .fmBlockWindow(explicit, "ctx", "t", list(data = qtlDatasetExample)), + explicit + ) + # Without one, the cis path's window is the trait's position +/- cisWindow + # -- the same interval .fmResidGenoBlock() slices X over. Widening the + # cis window must widen the recorded window. + cfgNarrow <- list(data = qtlDatasetExample, cisWindow = 1000) + cfgWide <- list(data = qtlDatasetExample, cisWindow = 500000) + ctx <- contexts(qtlDatasetExample)[[1L]] + tid <- rownames(molecularTraits(qtlDatasetExample, contexts = ctx))[[1L]] + narrow <- .fmBlockWindow(NULL, ctx, tid, cfgNarrow) + wide <- .fmBlockWindow(NULL, ctx, tid, cfgWide) + skip_if(is.null(narrow) || is.null(wide)) + expect_lt(GenomicRanges::start(wide), GenomicRanges::start(narrow)) + expect_gt(GenomicRanges::end(wide), GenomicRanges::end(narrow)) + expect_identical( + GenomicRanges::width(wide) - GenomicRanges::width(narrow), + 2L * (500000L - 1000L) + ) +}) + +test_that("a supplied block key survives into the result; a seqname fallback does not", { + data(gwasSumStatsS4Example) + gss <- gwasSumStatsS4Example + gr <- .collectionEntry(gss, 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) + + # (b) A coordinate-bearing key -- from an ldBlocks manifest or an explicit + # vector -- IS the block boundary and wins. 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)) + + # (c) 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) +}) + +# --------------------------------------------------------------------------- +# Provenance columns (dataType / dataSource / standardized) +# +# These three are what exportToBed() / exportToVcf() 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. +# --------------------------------------------------------------------------- + +# @noRd +.fmprov_cols <- function(res) { + as.data.frame(S4Vectors::mcols(res))[, + intersect( + c("dataType", "dataSource", "standardized"), + colnames(S4Vectors::mcols(res)) + ), + drop = FALSE + ] +} + +test_that("fineMappingPipeline(QtlDataset) records what it is given", { + data(qtlDatasetExample, envir = environment()) + res <- suppressMessages(fineMappingPipeline( + qtlDatasetExample, + methods = "susie", + cisWindow = 1e6, + dataType = "bulk_rnaseq" + )) + cols <- .fmprov_cols(res) + expect_equal(unique(cols$dataType), "bulk_rnaseq") + # Derived, not supplied: this entry point fits individual-level genotypes. + expect_equal(unique(cols$dataSource), "individual") + # Also derived: the genotypes were standardized on the way in, so there + # is nothing for a caller to declare and no way for it to be FALSE. + expect_true(all(cols$standardized)) +}) + +test_that("fineMappingPipeline(QtlDataset) omits dataType when not supplied", { + data(qtlDatasetExample, envir = environment()) + res <- suppressMessages(fineMappingPipeline( + qtlDatasetExample, + methods = "susie", + cisWindow = 1e6 + )) + # An absent label leaves the column out rather than filling it with NA -- + # an all-NA column is dropped on export anyway, and its absence is what + # the reader sees either way. + expect_false("dataType" %in% colnames(S4Vectors::mcols(res))) + cols <- .fmprov_cols(res) + expect_equal(unique(cols$dataSource), "individual") + expect_true(all(cols$standardized)) +}) + +test_that("fineMappingPipeline(QtlSumStats) records sumstat / standardized", { + res <- suppressWarnings(suppressMessages(fineMappingPipeline( + .rssf_qcd(), + methods = "susie", + dataType = "bulk_rnaseq" + ))) + cols <- .fmprov_cols(res) + expect_equal(unique(cols$dataType), "bulk_rnaseq") + expect_equal(unique(cols$dataSource), "sumstat") + # The RSS likelihood is written in standardized units, so the posterior + # effects are on that scale whatever the caller believes. + expect_true(all(cols$standardized)) +}) + +test_that("no pipeline takes a weight-scale declaration any more", { + # It was an argument while the caller's genotypes went to the fitter + # untouched. They are standardized on the way in now, so the flag is + # derived and a declaration could only contradict it. + expect_error( + fineMappingPipeline( + .rssf_qcd(), + methods = "susie", + weightStandardized = FALSE + ), + "unused argument" + ) + data(qtlDatasetExample, envir = environment()) + expect_error( + fineMappingPipeline( + qtlDatasetExample, + methods = "susie", + cisWindow = 1e6, + weightStandardized = FALSE + ), + "unused argument" + ) +}) + +test_that(".fmMsDataSource leaves a mixed collection's joint rows NA", { + mixed <- structure(list(), class = "fmprov_mixed") + local_mocked_bindings( + qtlDatasets = function(x, ...) list(1), + sumStats = function(x, ...) list(1), + .package = "pecotmr" + ) + expect_true(is.na(pecotmr:::.fmMsDataSource(mixed))) +}) + +test_that(".fmMsDataSource derives a single-kind collection's joint rows", { + local_mocked_bindings( + qtlDatasets = function(x, ...) list(), + sumStats = function(x, ...) list(1), + .package = "pecotmr" + ) + expect_equal(pecotmr:::.fmMsDataSource(NULL), "sumstat") + local_mocked_bindings( + qtlDatasets = function(x, ...) list(1), + sumStats = function(x, ...) list(), + .package = "pecotmr" + ) + expect_equal(pecotmr:::.fmMsDataSource(NULL), "individual") +}) + +test_that("individual-level genotypes reach the fitter standardized", { + # Through residualizedGenotypes(), which owns the scaling. + # The single preparation point for every individual-level fit in the + # package: fine-mapping's per-tuple and joint paths, the TWAS joint + # engine, and the top-PC construction all come through it. + data(qtlDatasetExample, envir = environment()) + X <- pecotmr:::.fmResidGeno( + qtlDatasetExample, + ResidualizationParam(), + contexts = "brain", + traitId = "ENSG_example", + cisWindow = 1e6 + ) + expect_true(max(abs(colMeans(X))) < 1e-10) + sds <- matrixStats::colSds(X) + 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. + data(qtlDatasetExample, envir = environment()) + recorded <- function(..., dataset = qtlDatasetExample) { + res <- suppressMessages(fineMappingPipeline( + dataset, + methods = "susie", + cisWindow = 1e6, + residualizationArgs = ResidualizationParam(...) + )) + unique(as.logical(S4Vectors::mcols(res)$standardized)) + } + 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", { + # The accessor owns it. A parallel step inside .fmResidGeno() would have + # covered only its own callers -- colocboostPipeline() calls + # residualizedGenotypes() directly and would have been left out. + expect_false(exists( + ".fmStandardizeGenotypes", + envir = asNamespace("pecotmr") + )) + expect_false(is_in( + "standardizeGenotypes", + names(formals(pecotmr:::.fmPipelineQtlDataset)) + )) +}) + +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") + )) + expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) +}) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 6e9c3f36..568d81d0 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -5,7 +5,11 @@ .makeAdjustEntry <- function(vids, maxNumSingleEffects = 2L) { p <- length(vids) set.seed(11L) - lbf <- matrix(rnorm(maxNumSingleEffects * p), nrow = maxNumSingleEffects, ncol = p) + lbf <- matrix( + rnorm(maxNumSingleEffects * p), + nrow = maxNumSingleEffects, + ncol = p + ) colnames(lbf) <- vids alpha <- lbfToAlpha(lbf) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) @@ -509,11 +513,22 @@ test_that("credibleSets / topLoci minPurity filters CS by purity, independent of # A fit whose alpha was built from a deliberately NON-uniform prior, so the # stored-alpha route and the rebuild-from-lbf route disagree. -.makeNonUniformPriorEntry <- function(vids, prior, maxNumSingleEffects = 2L, seed = 404L) { +.makeNonUniformPriorEntry <- function( + vids, + prior, + maxNumSingleEffects = 2L, + seed = 404L +) { p <- length(vids) set.seed(seed) - lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 2), maxNumSingleEffects, p, dimnames = list(NULL, vids)) - w <- exp(sweep(lbf, 1L, apply(lbf, 1L, max), `-`)) * rep(prior, each = maxNumSingleEffects) + lbf <- matrix( + rnorm(maxNumSingleEffects * p, sd = 2), + maxNumSingleEffects, + p, + dimnames = list(NULL, vids) + ) + w <- exp(sweep(lbf, 1L, apply(lbf, 1L, max), `-`)) * + rep(prior, each = maxNumSingleEffects) alpha <- w / rowSums(w) pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) list( @@ -758,7 +773,11 @@ test_that("lbf is empty when the fit carries no lbf matrix", { 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 + 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" @@ -856,8 +875,11 @@ test_that("credibleSetSummary returns one row per CS with size/purity/V/logBF/le expect_equal(s$cs_log_bf, c(1.9597, 1.2031), tolerance = 1e-3) # cs_pip = summed member PIP (inclusion mass captured) expect_equal(s$cs_pip, c(1.1, 0.8), tolerance = 1e-6) - # cs_mean_effect = NA for univariate susie (no conditional_effect column) - expect_true(all(is.na(s$cs_mean_effect))) + # cs_mean_effect = mean(posterior_mean / pip) over the members. It was NA + # for every univariate susie fit while it read a `conditional_effect` + # column that only multi-condition fits ever got -- an artefact of where + # the column came from, not of the quantity. + expect_true(all(is.finite(s$cs_mean_effect))) # lead = highest-PIP member expect_equal(s$lead_variant, c("chr1:100:A:G", "chr1:300:A:G")) }) @@ -1031,7 +1053,10 @@ test_that("fsusieCredibleBand returns a long effect + band table (lower <= effec skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") cb <- .fmrRowFsusieCredibleBand(.fsa_entry(.fsa_makeFit())) - expect_named(cb, c("cs", "chrom", "pos", "effect", "lower", "upper")) + expect_named( + cb, + c("cs", "chrom", "pos", "effect", "lower", "upper", "halfwidth") + ) expect_gt(nrow(cb), 0) expect_true(all( cb$lower <= cb$effect + 1e-9 & cb$effect <= cb$upper + 1e-9 @@ -1047,7 +1072,10 @@ test_that("trimmed fSuSiE keeps curves, bands and coloc inputs", { expectedFit <- pecotmr:::.fsusiePopulateCredibleBand(fit) tables <- list(list(sets = list(cs = list()))) trimmed <- pecotmr:::trimFinemappingFit( - fit, seq_along(fit$alpha), "fsusie", tables + fit, + seq_along(fit$alpha), + "fsusie", + tables ) entry <- unserialize(serialize(.fsa_entry(trimmed), NULL)) saved <- entry@susieFit @@ -1117,6 +1145,103 @@ test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no expect_equal(length(.fmrRowFsusieAffectedRegions(e)), 0L) }) +# ---- fsusieTraitEffects --------------------------------------------- + +# The pipeline stamps trait_positions onto 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) { + fit$trait_positions <- pos + fit +} + +test_that("fsusieTraitEffects evaluates the curve at each joint trait", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + fit <- .fsa_makeFit() + nTrait <- length(fit$outing_grid) + # Positions BETWEEN grid points, so the interpolation is doing real work. + pos <- as.numeric(seq_len(nTrait)) + 0.5 + names <- paste0("gene", seq_len(nTrait)) + res <- QtlFineMappingResult( + studyName = "s", + context = "brain", + trait = "g", + method = "fsusie", + entry = list(.fsa_entry(.fsa_jointFit(fit, pos))), + jointTraits = paste(names, collapse = ";") + ) + + te <- fsusieTraitEffects(res) + expect_true(all( + c( + "study", + "context", + "trait", + "method", + "cs", + "chrom", + "jointTrait", + "traitPos", + "effect" + ) %in% + names(te) + )) + nCs <- length(fit$fitted_func) + expect_equal(nrow(te), nCs * nTrait) + expect_equal(unique(te$jointTrait), names) + expect_equal(sort(unique(te$traitPos)), sort(pos)) + + # The effect is the fitted curve interpolated onto the trait positions, + # with constant extrapolation past the grid ends. + first <- te[te$cs == "fsusie_1", ] + expect_equal( + first$effect, + stats::approx( + as.numeric(fit$outing_grid), + as.numeric(fit$fitted_func[[1L]]), + xout = pos, + rule = 2, + ties = "ordered" + )$y + ) +}) + +test_that("fsusieTraitEffects refuses a fit whose positions and names disagree", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + fit <- .fsa_makeFit() + res <- QtlFineMappingResult( + studyName = "s", + context = "brain", + trait = "g", + method = "fsusie", + entry = list(.fsa_entry(.fsa_jointFit( + fit, + seq_along(fit$outing_grid) + ))), + jointTraits = "only;two" + ) + expect_error(fsusieTraitEffects(res), "trait position") +}) + +test_that("fsusieTraitEffects returns zero rows for a non-fsusie fit", { + res <- QtlFineMappingResult( + studyName = "s", + context = "brain", + trait = "g", + method = "susie", + 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) + )) + ) + te <- fsusieTraitEffects(res) + expect_equal(nrow(te), 0L) + 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") @@ -1367,7 +1492,11 @@ test_that("topLoci must list the variants in the same order", { .fmr_susieFit <- function(p = 5L, maxNumSingleEffects = 2L, seed = 7L) { set.seed(seed) - lbf <- matrix(rnorm(maxNumSingleEffects * p, sd = 3), maxNumSingleEffects, p) + lbf <- matrix( + rnorm(maxNumSingleEffects * p, sd = 3), + maxNumSingleEffects, + p + ) alpha <- lbfToAlpha(lbf) list( alpha = alpha, @@ -1590,12 +1719,24 @@ test_that("an untrimmed fit with no recorded coverage uses its primary sets", { expect_equal(pecotmr:::.csSetsForCoverage(fit, 0.95)$cs$L1, 1:2) }) -test_that("mean conditional effect is NA when the column is absent", { +test_that("mean conditional effect is the posterior mean over the PIP", { + # NA when either column the quotient needs is absent. expect_true(is.na(pecotmr:::.csMeanEffect(tibble(a = 1)))) + expect_true(is.na(pecotmr:::.csMeanEffect(tibble(pip = c(0.5, 0.5))))) expect_equal( - pecotmr:::.csMeanEffect(tibble(conditional_effect = c(1, 3))), + pecotmr:::.csMeanEffect( + tibble(posterior_mean = c(0.5, 1.5), pip = c(0.5, 0.5)) + ), 2 ) + # A zero PIP has no conditional effect to speak of, so it drops out + # rather than contributing an infinity. + expect_equal( + pecotmr:::.csMeanEffect( + tibble(posterior_mean = c(0.5, 1), pip = c(0.5, 0)) + ), + 1 + ) }) test_that("rebuilding an empty topLoci returns it unchanged", { @@ -1731,15 +1872,178 @@ test_that(".csLog10Bf and .csMeanEffect return NA, never -Inf or NaN", { expect_identical(pecotmr:::.csMeanEffect(list()), NA_real_) expect_identical( - pecotmr:::.csMeanEffect(list(conditional_effect = numeric(0))), + pecotmr:::.csMeanEffect( + list(posterior_mean = numeric(0), pip = numeric(0)) + ), NA_real_ ) expect_identical( - pecotmr:::.csMeanEffect(list(conditional_effect = c(NA, NA))), + pecotmr:::.csMeanEffect( + list(posterior_mean = c(NA, NA), pip = c(0.5, 0.5)) + ), NA_real_ ) expect_identical( - pecotmr:::.csMeanEffect(list(conditional_effect = c(1, 3))), + pecotmr:::.csMeanEffect( + list(posterior_mean = c(0.5, 1.5), pip = c(0.5, 0.5)) + ), 2 ) }) + +test_that("fsusieCredibleBand() carries the band half-width", { + data(fsusieFineMappingExample) + band <- as.data.frame(fsusieCredibleBand(fsusieFineMappingExample)) + expect_true(is_in("halfwidth", names(band))) + expect_gt(nrow(band), 0L) + expect_equal(band$halfwidth, (band$upper - band$lower) / 2) + # A band half-width is a magnitude, never negative. + expect_true(all(band$halfwidth >= 0)) +}) + +test_that("an empty credible band still declares halfwidth", { + expect_true(is_in("halfwidth", names(.emptyCredibleBand()))) + expect_identical(nrow(.emptyCredibleBand()), 0L) +}) + +# --------------------------------------------------------------------------- +# fsusie trait-effect edge paths, and the two projections either side of them +# --------------------------------------------------------------------------- + +# The minimum a fit needs to pass `.isFsusieFit()` and carry trait positions: +# one curve per effect over `outing_grid`, plus the two fields that identify a +# susiF fit. A `NULL` element of `fitted_func` is what an effect that produced +# no curve looks like. +# @noRd +.fte_stubFit <- function(curves, pos) { + list( + fitted_func = curves, + outing_grid = c(1, 2, 3), + fitted_wc2 = 1, + alpha = 1, + trait_positions = pos + ) +} + +# @noRd +.fte_row <- function(fit) { + fineMappingRow( + variantIds = "chr1:100:A:G", + susieFit = fit, + topLoci = data.frame( + variant_id = "chr1:100:A:G", + pip = 0.5, + stringsAsFactors = FALSE + ) + ) +} + +test_that("an effect with no fitted curve contributes no trait effects", { + res <- QtlFineMappingResult( + studyName = "s", + context = "brain", + trait = "g", + method = "fsusie", + entry = list(.fte_row(.fte_stubFit(list(NULL, NULL), 1.5))), + jointTraits = "g1" + ) + te <- fsusieTraitEffects(res) + # Every effect skipped, so there is nothing to report -- but the empty + # table keeps the schema, so a caller can bind or filter it exactly as it + # would a populated one. + expect_equal(nrow(te), 0L) + expect_true(all( + c("cs", "chrom", "jointTrait", "traitPos", "effect") %in% names(te) + )) +}) + +test_that("a fit with no jointTraits names its curves after the row", { + res <- QtlFineMappingResult( + studyName = "s", + context = "brain", + trait = "g", + method = "fsusie", + entry = list(.fte_row(.fte_stubFit(list(c(1, 2, 3)), 1.5))) + ) + te <- fsusieTraitEffects(res) + # The joint member names ride on `jointTraits`; a fit over a single trait + # has none, so the row's own trait is the name of its curve. + expect_equal(nrow(te), 1L) + expect_equal(te$jointTrait, "g") + # The curve is linear on the grid, so the midpoint interpolates exactly. + expect_equal(te$effect, 1.5) +}) + +test_that("a GWAS fsusie fit has no trait axis to name its curves", { + res <- GwasFineMappingResult( + studyName = "s", + method = "fsusie", + entry = list(.fte_row(.fte_stubFit(list(c(1, 2, 3)), 1.5))) + ) + # A GWAS result is not keyed by trait at all, so there is no name to fall + # back to and the fit's one trait position has nothing to pair with. + expect_error( + fsusieTraitEffects(res), + "1 trait position\\(s\\) but 0 trait name\\(s\\)" + ) +}) + +test_that("a credible-set label matching no fit effect claims none", { + tl <- data.frame( + variant_id = "chr1:100:A:G", + cs_95 = "fsusie_1", + stringsAsFactors = FALSE + ) + # The label's variants are not any effect's membership, so the label has + # no effect to attach to -- NA rather than silently taking the first. + expect_true(is.na(.fsusieFirstMatchingEffect( + "fsusie_1", + fitSets = list("chr1:200:A:G", "chr1:300:A:G"), + topLoci = tl + ))) + expect_equal( + .fsusieFirstMatchingEffect( + "fsusie_1", + fitSets = list("chr1:300:A:G", "chr1:100:A:G"), + topLoci = tl + ), + 2L + ) +}) + +test_that("a NULL posterior table projects to an empty GRanges", { + gr <- .fmeTopLociGRanges(NULL) + expect_s4_class(gr, "GRanges") + expect_length(gr, 0L) +}) + +test_that("a fit whose prior variances all vanished labels nothing", { + vids <- str_c("chr1:", (1:4) * 100, ":A:G") + p <- length(vids) + L <- 2L + set.seed(3L) + lbf <- matrix(stats::rnorm(L * p), nrow = L, ncol = p) + colnames(lbf) <- vids + alpha <- lbfToAlpha(lbf) + pip <- as.numeric(1 - apply(1 - alpha, 2, prod)) + entry <- fineMappingRow( + variantIds = vids, + susieFit = list( + pip = pip, + alpha = alpha, + lbf_variable = lbf, + # Every prior variance driven to zero: no effect clears the + # tolerance, so there is no credible set left to label with. + V = rep(0, L) + ), + topLoci = data.frame( + variant_id = vids, + pip = pip, + method = "susie", + cs_95 = c("susie_1", rep("susie_0", p - 1L)), + stringsAsFactors = FALSE + ) + ) + adj <- adjustPips(entry, vids[1:3]) + expect_equal(.fmrRowTopLoci(adj, raw = TRUE)$cs_95, rep("susie_0", 3L)) +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index cbfe9044..0300aef2 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -631,6 +631,9 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { "marginal_beta", "marginal_se", "marginal_z", + # Whether the SOURCE supplied z, which is what GWAS-VCF's `EZ` means: a + # Wald z pecotmr derived from beta/se must not be published as provided. + "marginal_z_supplied", "marginal_p", "pip", "posterior_mean", @@ -757,6 +760,11 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { otherQuantities = NULL, region = NULL ) { + # `signalCutoff` has to go to buildTopLoci's OWN formal: that is the one + # the PIP filter reads, and it is what the pipeline unpacks from + # CredibleSetParam before calling here. Setting it only on the param -- + # which this helper used to do -- left every caller's cutoff inert, so a + # test asking for 0.5 was silently testing no filtering at all. buildTopLoci( fit = inp$fit, csTables = inp$cs_tables, @@ -764,6 +772,7 @@ if (!exists(".makeUnivariateData", inherits = FALSE)) { sumstats = sumstats, af = af, method = method, + signalCutoff = signalCutoff, dataY = inp$data_y, otherQuantities = otherQuantities, region = region, @@ -913,11 +922,12 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { method = "mvsusie", conditionIdx = 1L ) - expect_true(all(c("conditional_effect", "lfsr") %in% names(tl1))) - expect_true(is.numeric(tl1$conditional_effect) && is.numeric(tl1$lfsr)) - # conditional_effect = coef[, condition] / pip, for every variant - expect_equal(unname(tl1$conditional_effect), unname(coef[, 1] / pip)) - # lfsr populated ONLY for the 0.95 CS variants, pulled from clfsr[L, variant, condition] + expect_true(is_in("lfsr", names(tl1))) + expect_true(is.numeric(tl1$lfsr)) + # `conditional_effect` is gone: it was coef[, condition] / pip, and the + # posterior mean is on coef()'s scale now, so the table already held it. + expect_false(is_in("conditional_effect", names(tl1))) + # lfsr populated ONLY for the 0.95 CS variants, from clfsr[L, variant, condition] expect_equal(tl1$lfsr[1:2], c(0.001, 0.02)) expect_true(all(is.na(tl1$lfsr[3:4]))) # conditionIdx = 2 selects the other condition's coef + clfsr slice @@ -928,14 +938,13 @@ test_that("buildTopLoci: mvsusie per-condition lfsr + effect (long)", { method = "mvsusie", conditionIdx = 2L ) - expect_equal(unname(tl2$conditional_effect), unname(coef[, 2] / pip)) expect_equal(tl2$lfsr[1:2], c(0.30, 0.40)) # univariate fit (no conditionIdx) keeps the base schema, no extra columns tl0 <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") expect_false(any(c("conditional_effect", "lfsr") %in% names(tl0))) }) -test_that("topLoci surfaces mvsusie conditional_effect + lfsr through the projector", { +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", @@ -946,7 +955,6 @@ test_that("topLoci surfaces mvsusie conditional_effect + lfsr through the projec posterior_mean = c(0.1, 0.2), posterior_sd = c(0.05, 0.05), cs_95 = c("mvsusie_1", "mvsusie_1"), - conditional_effect = c(0.3, -0.2), lfsr = c(0.001, 0.02), stringsAsFactors = FALSE ) @@ -956,9 +964,8 @@ test_that("topLoci surfaces mvsusie conditional_effect + lfsr through the projec topLoci = tl ) out <- .fmrRowTopLoci(e, signalCutoff = 0) - expect_true(all(c("conditional_effect", "lfsr") %in% names(out))) + expect_true(is_in("lfsr", names(out))) expect_equal(out$lfsr, c(0.001, 0.02)) - expect_equal(out$conditional_effect, c(0.3, -0.2)) }) test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcoded 0.95/0.70/0.50)", { @@ -1694,7 +1701,10 @@ test_that("missing region produces NA grange columns rather than silent omission expect_equal(unique(out$event), "ctx_ENSG00000179403") }) -test_that("posterior_mean equals colSums(alpha*mu); posterior_sd equals sqrt(pmax(colSums(alpha*mu2) - mean^2, 0))", { +test_that("posterior_mean is colSums(alpha*mu) when the fit records no scale", { + # The no-scale-factors case: an RSS fit has no X to scale, and a fit run + # with standardize = FALSE records all-1s, so the quotient below is the + # identity. The division itself is pinned by the next test. variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") cs_at_cov <- list( "0.95" = list(c(1L, 2L)), @@ -1726,6 +1736,47 @@ test_that("posterior_mean equals colSums(alpha*mu); posterior_sd equals sqrt(pma }) +test_that("posterior_mean and posterior_sd are on the SUPPLIED X scale", { + # `.btlPosterior()` reports what `susieR::coef.susie()` reports: + # (colSums(alpha*mu) + theta) / X_column_scale_factors. Without the + # division this column was the only quantity in the package on the + # standardized scale, so the same fit gave two different "posterior + # effects" depending on whether you read topLoci() or susieWeights(). + nV <- 3L + fit <- list( + alpha = matrix( + c(0.6, 0.3, 0.1, 0.2, 0.7, 0.1), + nrow = 2L, + byrow = TRUE + ), + mu = matrix(c(0.5, 1.0, 2.0, 0.4, 0.8, 1.6), nrow = 2L, byrow = TRUE), + mu2 = matrix(c(0.5, 1.2, 4.2, 0.4, 0.9, 3.0), nrow = 2L, byrow = TRUE), + X_column_scale_factors = c(0.5, 2, 4) + ) + meanStd <- colSums(fit$alpha * fit$mu) + sdStd <- sqrt(pmax(colSums(fit$alpha * fit$mu2) - meanStd^2, 0)) + post <- pecotmr:::.btlPosterior(fit, NULL, nV) + expect_equal(post$postMean, meanStd / fit$X_column_scale_factors) + # An SD rescales the way its mean does, but the mu2 identity only holds + # in the units mu2 is stored in -- so it is computed there, then divided. + expect_equal(post$postSd, sdStd / fit$X_column_scale_factors) + + # susieInf / susieAsh carry an infinitesimal term that coef.susie adds in; + # dropping it would silently change what the posterior effect means. + withTheta <- `$<-`(fit, "theta", c(0.1, -0.2, 0.05)) + expect_equal( + pecotmr:::.btlPosterior(withTheta, NULL, nV)$postMean, + (meanStd + withTheta$theta) / fit$X_column_scale_factors + ) + + # A zero factor can only come from a constant column, which carries no + # effect: treated as 1 rather than dividing to Inf. + zeroed <- `$<-`(fit, "X_column_scale_factors", c(0.5, 0, 4)) + expect_true(all(is.finite( + pecotmr:::.btlPosterior(zeroed, NULL, nV)$postMean + ))) +}) + # ---- cal_purity ---- test_that("cal_purity with min method and single element CS", { set.seed(42) @@ -3618,14 +3669,6 @@ test_that("the N column falls back to the fit N and recycles a scalar", { # buildTopLoci per-condition blocks # =========================================================================== -test_that("conditional effects are NA when the fit carries no coefficients", { - # susie without a coef matrix and no mvsusie fallback: one NA per variant - # rather than a shorter vector that would misalign the column. - out <- pecotmr:::.btlCondEffect(list(), "susie", 1L, 3L) - expect_length(out, 3L) - expect_true(all(is.na(out))) -}) - test_that("conditional lfsr passes through when no coverage level matches", { clf <- array(0.1, dim = c(2L, 3L, 1L)) out <- pecotmr:::.btlCondLfsr( @@ -5240,3 +5283,213 @@ 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 +# --------------------------------------------------------------------------- + +test_that("signalCutoff drops rows at or below the cutoff", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:T") + noCs <- list("0.95" = list(), "0.7" = list(), "0.5" = list()) + inp <- .fakeFitAndCs(vids, noCs, pip = c(0.02, 0.4, 0.95)) + # 0 (and NULL) keeps everything: the cutoff is a publication filter, not + # part of the fit. + expect_equal(nrow(.runBuildTopLoci(inp, signalCutoff = 0)), 3L) + # Strictly greater than the cutoff survives, so 0.4 goes at 0.5 and + # stays at 0.3. + expect_equal( + .runBuildTopLoci(inp, signalCutoff = 0.3)$variant_id, + vids[2:3] + ) + expect_equal( + .runBuildTopLoci(inp, signalCutoff = 0.5)$variant_id, + vids[[3L]] + ) +}) + +test_that("a z-only source still reports an effect size", { + vids <- c("chr1:100:A:G", "chr1:200:C:T") + noCs <- list("0.95" = list(), "0.7" = list(), "0.5" = list()) + inp <- .fakeFitAndCs(vids, noCs, pip = c(0.9, 0.8)) + af <- c(0.2, 0.35) + n <- 1000 + z <- c(3.5, -2.1) + out <- buildTopLoci( + fit = inp$fit, + csTables = inp$cs_tables, + variantNames = inp$variantNames, + # A GWAS that published only z, which is routine: with af and N the + # model inverts to an effect size, and leaving the columns NA would + # lose the study for every effect-size consumer downstream. + sumstats = list(z = z), + af = af, + n = n, + method = "susie", + dataY = inp$data_y + ) + se <- 1 / sqrt(2 * af * (1 - af) * (n + z^2)) + expect_equal(out$marginal_se, se) + expect_equal(out$marginal_beta, z * se) + # The z was the source's own, which is what the published EZ field means. + expect_true(all(out$marginal_z_supplied)) +}) + +test_that("a z-only source with no af or N leaves the effect unfilled", { + vids <- c("chr1:100:A:G", "chr1:200:C:T") + noCs <- list("0.95" = list(), "0.7" = list(), "0.5" = list()) + inp <- .fakeFitAndCs(vids, noCs, pip = c(0.9, 0.8)) + out <- buildTopLoci( + fit = inp$fit, + csTables = inp$cs_tables, + variantNames = inp$variantNames, + sumstats = list(z = c(3.5, -2.1)), + method = "susie", + dataY = inp$data_y + ) + # Without the frequency and sample size the model cannot be inverted, so + # the columns stay empty rather than being filled with a guess. + expect_true(all(is.na(out$marginal_beta))) + expect_true(all(is.na(out$marginal_se))) + expect_equal(out$marginal_z, c(3.5, -2.1)) +}) + +test_that("the RSS weight extractors refuse to fine-map themselves", { + # These read weights off an existing fit; without one there is nothing to + # extract, and the message says where the fit comes from. + expect_error( + susieRssWeights(stat = list(z = 1), LD = diag(2)), + "susieRssWeights: no 'susie' fit supplied" + ) + expect_error( + susieInfRssWeights(stat = list(z = 1), LD = diag(2)), + "susieInfRssWeights: no 'susieInf' fit supplied" + ) + expect_error( + susieAshRssWeights(stat = list(z = 1), LD = diag(2)), + "susieAshRssWeights: no 'susieAsh' fit supplied" + ) +}) + +# --------------------------------------------------------------------------- +# Degenerate inputs the fine-mapping helpers have to absorb +# --------------------------------------------------------------------------- + +test_that("an out-of-range credible-set position yields no within-CS PIP", { + # The primary CS position points at effect 5 of a one-effect fit, so + # there is no row of alpha to read the within-CS share from. + expect_equal( + .ffcWithinPip( + alpha = matrix(0.5, nrow = 1L, ncol = 3L), + primaryCsPos = c(1L, 1L, 1L), + effectOf = 5L, + nV = 3L, + hasAlpha = TRUE + ), + rep(NA_real_, 3L) + ) +}) + +test_that("a credible set with no members assigns no variant", { + # The coverage matches and the set list is non-empty, but the set itself + # holds no variant, so every variant stays unassigned (0). + expect_equal( + .fmCsIdxAtCoverage( + targetCov = 0.95, + coverageValues = 0.95, + csTables = list(list(sets = list(cs = list(L1 = integer(0))))), + nV = 3L + ), + integer(3L) + ) +}) + +test_that("mu and mu2 of different shapes yield no conditional lfsr", { + # mu2 is the second moment of mu, so a shape disagreement means the two + # describe different fits -- no lfsr rather than a recycled one. + expect_null(.btlUnivariateClfsr(list( + mu = matrix(0, 2L, 3L), + mu2 = matrix(1, 2L, 4L) + ))) +}) + +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) + expect_equal(once[["b"]], "a") + # Both now have the same root, so the second merge is a no-op rather than + # re-pointing a root at itself. + expect_identical(.ufUnion("a", "b", once), once) + expect_identical(.ufUnion("b", "a", once), once) +}) + +test_that("a purity calculation that fails leaves the sets untouched", { + skip_if_not_installed("fsusieR") + sets <- list(cs = list(L1 = 1:2)) + # cal_purity needs the genotype matrix the sets index into; given + # something else it errors, and purity is simply absent rather than the + # credible sets being lost with it. + expect_identical(.fsusieSetsWithPurity(sets, "not-a-matrix"), sets) +}) + +test_that("a frequency vector that does not match the variants is not used", { + # af has one value for two variants. Recycling it would attach one + # variant's frequency to the other and derive an effect size from it, so + # the fill-in declines instead and the columns stay empty. + out <- .btlFillFromZ( + beta = rep(NA_real_, 2L), + se = rep(NA_real_, 2L), + z = c(1.5, -2.5), + af = 0.2, + n = 1000, + nV = 2L + ) + expect_true(all(is.na(out$beta))) + expect_true(all(is.na(out$se))) + # A single N for every variant IS allowed -- one sample size can describe + # the whole study, where one frequency cannot. + ok <- .btlFillFromZ( + beta = rep(NA_real_, 2L), + se = rep(NA_real_, 2L), + z = c(1.5, -2.5), + af = c(0.2, 0.3), + n = 1000, + nV = 2L + ) + expect_false(anyNA(ok$beta)) +}) + +test_that("an unnormalisable id set is returned as given", { + # `normalizeVariantId()` leaves an id it cannot parse alone rather than + # emitting "chrNA:..." garbage, so a fit named by rsID keeps its names + # and only the parseable ones are rewritten. + out <- extractVariantNames(list( + pip = set_names( + c(0.1, 0.2, 0.3), + c( + "rs12345", + "chr1_200_C_T", + "not an id" + ) + ) + )) + expect_equal(out, c("rs12345", "chr1:200:C:T", "not an id")) +}) + +test_that("a screen whose marginal z cannot be computed falls back", { + # univariate_regression refuses a non-finite X, and the screen is + # advisory: a block it cannot score is kept (the fineMapping default) + # rather than silently discarded. + X <- matrix(c(Inf, stats::rnorm(49L)), nrow = 10L, ncol = 5L) + y <- stats::rnorm(10L) + scr <- list(metric = "absZ", cutoff = 2) + expect_true(.fmSerScreen(X, y, scr, fallback = TRUE)) + # colocboost passes FALSE: it drops an outcome it cannot screen. + expect_false(.fmSerScreen(X, y, scr, fallback = FALSE)) +}) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index 554ebce6..84a1e201 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -3123,3 +3123,22 @@ test_that(".twasEnsembleCollect answers empty parts when no token contributes", expect_identical(out$wts, list()) expect_identical(out$rsq, c()) }) + +test_that(".jointAfForGroup resolves allele frequencies for an individual group", { + data(qtlDatasetExample) + X <- matrix( + c(0, 1, 2, 1, 2, 0), + nrow = 3, + dimnames = list(c("s1", "s2", "s3"), c("chr1:100:A:T", "chr1:200:C:G")) + ) + g <- new( + "IndividualJointGroup", + conditions = tibble(study = "s", context = "c", trait = "t"), + X = X, + Y = matrix(1:3, ncol = 1, dimnames = list(c("s1", "s2", "s3"), "c:t")) + ) + # 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. + expect_null(.jointAfForGroup(qtlDatasetExample, "not a group")) +}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index 7c4772da..8ab98967 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -1816,3 +1816,79 @@ test_that("manifest loaders guard the QtlDataset pass-through arguments", { "xvarCutoff.*is not >= 0" ) }) + +# --------------------------------------------------------------------------- +# AF vs MAF on the GWAS-VCF path +# +# `AF` is the spec's ALTERNATIVE-allele frequency -- directional, and what the +# posterior view publishes as `af`. It used to be a fallback for the MAF slot +# and was then folded with pmin(af, 1 - af), so an AF of 0.8 came back as a +# MAF of 0.2 with no `AF` column at all: pecotmr's own VCF output did not +# round-trip, and the direction the standardized-to-raw weight conversion +# needs was gone. The mirror of the released writer bug where `AF` held MAF. +# --------------------------------------------------------------------------- + +# @noRd +.afvcf_sumstats <- function(af = c(0.8, 0.3)) { + 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), + z_supplied = c(TRUE, TRUE) + ) + if (!is.null(af)) { + cols$AF <- af + } + GwasSumStats( + studyName = "s", + entry = list(S4Vectors::`mcols<-`(gr, value = cols)), + genome = "hg38" + ) +} + +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) + 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. + expect_equal(as.numeric(back$AF), c(0.8, 0.3)) + # A directionless MAF is still derived for QC, alongside AF rather than + # instead of it. + expect_equal(as.numeric(back$MAF), c(0.2, 0.3)) +}) + +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) + back <- .readSumStatsVcf(out, NULL, NULL, NULL, "x") + expect_false(is_in("AF", names(back))) + expect_false(is_in("MAF", names(back))) +}) + +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) + # 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( + out, + NULL, + NULL, + list(AF = "NOPE", MAF = "AF"), + "x" + ) + expect_false(is_in("AF", names(back))) + expect_equal(as.numeric(back$MAF), c(0.2, 0.3)) +}) diff --git a/tests/testthat/test_overlapTopLoci.R b/tests/testthat/test_overlapTopLoci.R index cd3c5e2b..73c43694 100644 --- a/tests/testthat/test_overlapTopLoci.R +++ b/tests/testthat/test_overlapTopLoci.R @@ -191,5 +191,5 @@ test_that("overlapTopLoci returns a GRanges of the shared variants", { gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0) expect_s4_class(gr, "GRanges") expect_equal(length(gr), 1L) - expect_true("gwas_beta" %in% names(S4Vectors::mcols(gr))) + expect_true("gwas_posterior_effect" %in% names(S4Vectors::mcols(gr))) }) diff --git a/tests/testthat/test_resultReaders.R b/tests/testthat/test_resultReaders.R new file mode 100644 index 00000000..d6dca5a6 --- /dev/null +++ b/tests/testthat/test_resultReaders.R @@ -0,0 +1,976 @@ +# --------------------------------------------------------------------------- +# Published result readers: readFineMappingResult() / readTwasWeights() +# +# The reader and the writer are each other's only real test. Each direction +# had only ever been checked against a stored fixture before, which is how the +# two came to disagree about a reserved key while both "passed" -- so most of +# what is here is a round trip, and the comparisons are against the ORIGINAL +# object rather than against a file. +# --------------------------------------------------------------------------- + +# @noRd +.rdr_tmp <- function(name) file.path(tempdir(), name) + +# The ways a round trip legitimately differs from its input, so a test can say +# "everything else is identical" and mean it: +# dataSource / standardized ADDED on the way back (one is derived by the +# writer, the other supplied to the reader) +# cs_ the published form is an integer index, and "susie_0" -- the +# not-captured sentinel -- publishes as NA, which is the canonical form +# every reader of the column already treats as "in no credible set" +# z_supplied resolved from NA to FALSE: a file publishing ES/SE and no EZ +# says the z was NOT supplied by the source, which is what the fixture's +# NA meant before the flag existed +# @noRd +.RDR_NORMALIZED <- c( + "dataSource", + "standardized", + "cs_95", + "cs_70", + "cs_50", + "z_supplied" +) + +# Which columns of two per-variant tables disagree, aligned on variant id. +# +# Aligned rather than compared in place because a published file is sorted +# genomically and the stored table is not, and restricted to the variants +# `b` carries because an export is topLoci-FILTERED by default -- the +# question is whether what was published came back intact, not whether a +# filtered file holds every variant of the fit. +# @noRd +.rdr_diff <- function(a, b, tolerance = 1e-6) { + a <- a[is_in(a$variant_id, b$variant_id), ] + b <- b[match(a$variant_id, b$variant_id), ] + shared <- intersect(names(a), names(b)) + bad <- character(0) + for (nm in shared) { + va <- a[[nm]] + vb <- b[[nm]] + ok <- if (is.numeric(va) && is.numeric(vb)) { + isTRUE(all.equal(va, vb, tolerance = tolerance)) + } else { + identical(as.character(va), as.character(vb)) + } + if (!ok) { + bad <- c(bad, nm) + } + } + setdiff(bad, .RDR_NORMALIZED) +} + +# A minimal published table written by hand, as a user converting another +# tool's output would produce it. +# @noRd +.rdr_writeTable <- function(df, name) { + path <- .rdr_tmp(name) + utils::write.table( + df, + path, + sep = "\t", + quote = FALSE, + row.names = FALSE, + na = "NA" + ) + path +} + +# ---- 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") + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_s4_class(back, "QtlFineMappingResult") + expect_equal(nrow(back), nrow(qtlFineMappingExample)) + expect_equal( + .rdr_diff( + as.data.frame(topLoci(qtlFineMappingExample)), + as.data.frame(topLoci(back)) + ), + character(0) + ) + # The marginal view is the other half of the same table and has its own + # published fields (ES/SE/EZ/LP), so it is checked separately. + expect_equal( + .rdr_diff( + as.data.frame(marginalEffects(qtlFineMappingExample)), + as.data.frame(marginalEffects(back)) + ), + character(0) + ) + # The analysis WINDOW, without which genomicRegion() silently degrades to + # the span of the variants that survived QC. + expect_equal( + genomicRegion(back), + genomicRegion(qtlFineMappingExample) + ) +}) + +test_that("a fine-mapping result round-trips through a published VCF", { + data(qtlFineMappingExample, envir = environment()) + path <- .rdr_tmp("rt_fm.vcf") + exportToVcf(qtlFineMappingExample, path, context = "context_1") + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_s4_class(back, "QtlFineMappingResult") + expect_equal( + .rdr_diff( + as.data.frame(topLoci(qtlFineMappingExample)), + as.data.frame(topLoci(back)), + tolerance = 1e-5 + ), + character(0) + ) + expect_equal(genomicRegion(back), genomicRegion(qtlFineMappingExample)) +}) + +test_that("the two formats agree with each other", { + # 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") + fromBed <- readFineMappingResult(bed, weightStandardized = TRUE) + fromVcf <- readFineMappingResult(vcf, weightStandardized = TRUE) + expect_equal(genomicRegion(fromBed), genomicRegion(fromVcf)) + expect_equal( + .rdr_diff( + as.data.frame(topLoci(fromBed)), + as.data.frame(topLoci(fromVcf)), + tolerance = 1e-5 + ), + character(0) + ) +}) + +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. + data(qtlFineMappingExample, envir = environment()) + path <- .rdr_tmp("fit.vcf") + exportToVcf(qtlFineMappingExample, path, context = "context_1") + fit <- susieFit(readFineMappingResult(path, weightStandardized = TRUE)) + original <- susieFit(qtlFineMappingExample) + expect_equal(as.numeric(fit$V), as.numeric(original$V), tolerance = 1e-8) + expect_equal( + as.integer(fit$sets$cs_index), + as.integer(original$sets$cs_index) + ) + # 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) + expect_null(susieFit(readFineMappingResult(bed, weightStandardized = TRUE))) +}) + +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), + "fine-mapping-derived" + ) + back <- readTwasWeights(path) + # Fine-mapping-derived rows are skipped on export, so fewer rows come + # back than went out -- that is the writer's rule, not a reader loss. + expect_lt(nrow(back), nrow(twasWeightsExample)) + md <- S4Vectors::mcols(back) + for (i in seq_len(nrow(back))) { + key <- list( + studyName = as.character(md$study[[i]]), + context = as.character(md$context[[i]]), + trait = as.character(md$trait[[i]]), + method = as.character(md$method[[i]]) + ) + was <- exec(resolveWeights, twasWeightsExample, !!!key) + now <- exec(resolveWeights, back, !!!key) + expect_setequal(now$variantIds, was$variantIds) + expect_equal( + as.numeric(now$weights)[order(now$variantIds)], + as.numeric(was$weights)[order(was$variantIds)], + tolerance = 1e-10 + ) + } + expect_equal( + genomicRegion(back), + genomicRegion(twasWeightsExample)[ + match( + as.character(md$method), + as.character(S4Vectors::mcols(twasWeightsExample)$method) + ) + ] + ) +}) + +# ---- multi-row tables ----------------------------------------------------- + +test_that("a merged table reads back as a multi-row collection", { + data(qtlFineMappingExample, qtlFineMappingLbfExample, envir = environment()) + combined <- combineFineMappingResults( + qtlFineMappingExample, + qtlFineMappingLbfExample + ) + path <- .rdr_tmp("merged.bed") + exportToBed(combined, path) + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_equal(nrow(back), nrow(combined)) + md <- S4Vectors::mcols(back) + expect_setequal( + as.character(md$trait), + as.character(S4Vectors::mcols(combined)$trait) + ) +}) + +test_that("a per-result value that disagrees within one tuple is an error", { + # Two results concatenated under one identity. Picking either window + # would silently publish one fit's region as the other's. + df <- data.frame( + `#chr` = c("chr1", "chr1"), + start = c(99L, 199L), + end = c(100L, 200L), + ID = c("chr1:100:A:G", "chr1:200:C:T"), + PIP = c(0.9, 0.1), + study = c("s", "s"), + context = c("c", "c"), + trait = c("t", "t"), + method = c("susie", "susie"), + region_start = c(0L, 500L), + region_end = c(1000L, 1500L), + check.names = FALSE + ) + path <- .rdr_writeTable(df, "clash.bed") + expect_error( + readFineMappingResult(path), + "`region_start` takes 2 different values" + ) +}) + +# ---- supplying what the file does not record ------------------------------- + +test_that("identity arguments fill in a file that did not record them", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + check.names = FALSE + ) + path <- .rdr_writeTable(df, "bare.bed") + back <- readFineMappingResult( + path, + studyName = "s", + context = "c", + trait = "t", + method = "susie" + ) + expect_s4_class(back, "QtlFineMappingResult") + md <- S4Vectors::mcols(back) + expect_equal(as.character(md$study), "s") + expect_equal(as.character(md$method), "susie") + expect_equal(as.numeric(topLoci(back)$pip), 0.9) +}) + +test_that("an identity argument that disagrees with the file is an error", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + study = "recorded", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "disagree.bed") + expect_error( + readFineMappingResult(path, studyName = "supplied"), + "was given as 'supplied' but the file records 'recorded'" + ) + # Dropping the argument uses the file's value. + expect_equal( + as.character(S4Vectors::mcols(readFineMappingResult(path))$study), + "recorded" + ) +}) + +test_that("a result keyed by axes the file lacks names them", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + context = "c", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "noaxes.bed") + expect_error( + readFineMappingResult(path), + "does not record study, trait, method.*`studyName`, `trait`, `method`" + ) +}) + +# ---- permissiveness ------------------------------------------------------- + +test_that("a table carrying only PIP is enough for a fine-mapping result", { + # TWAS needs only the weight, MR beta/se/PIP, colocalization the LBF. A + # file converted from another tool has some and not others, so the reader + # requires only what the class cannot exist without. + df <- data.frame( + `#chr` = c("chr1", "chr1"), + start = c(99L, 199L), + end = c(100L, 200L), + ID = c("chr1:100:A:G", "chr1:200:C:T"), + PIP = c(0.9, 0.05), + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "pip_only.bed") + back <- readFineMappingResult(path) + tl <- topLoci(back, signalCutoff = 0) + expect_equal(length(tl), 2L) + expect_equal(as.numeric(S4Vectors::mcols(tl)$pip), c(0.9, 0.05)) + # Absent columns are absent, not NA-filled: nothing invents a beta. + expect_true(all(is.na(marginalEffects(back)$beta))) +}) + +test_that("a table carrying only a weight is enough for TwasWeights", { + df <- data.frame( + `#chr` = c("chr1", "chr1"), + start = c(99L, 199L), + end = c(100L, 200L), + ID = c("chr1:100:A:G", "chr1:200:C:T"), + WGT = c(0.3, -0.2), + study = "s", + context = "c", + trait = "t", + method = "lasso", + weight_standardized = TRUE, + check.names = FALSE + ) + path <- .rdr_writeTable(df, "wgt_only.bed") + back <- readTwasWeights(path) + w <- resolveWeights(back) + expect_equal(as.numeric(w$weights), c(0.3, -0.2)) + expect_true(weightStandardized(back)) +}) + +test_that("ids are rebuilt from coordinates when ID does not encode them", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "rs123", + REF = "A", + ALT = "G", + PIP = 0.9, + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "rsid.bed") + back <- readFineMappingResult(path) + expect_equal(variantIds(back), "chr1:100:A:G") +}) + +test_that("a table with no way to identify its variants says so", { + df <- data.frame( + ID = "rs123", + PIP = 0.9, + check.names = FALSE + ) + path <- .rdr_writeTable(df, "noid.bed") + expect_error( + readFineMappingResult(path, studyName = "s"), + "must identify its variants" + ) +}) + +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)) + expect_error( + readFineMappingResult(wt, weightStandardized = TRUE), + "no `PIP` column.*readTwasWeights" + ) +}) + +test_that("a fine-mapping table reads as weights, because WGT is the weight", { + # Not a category error in this direction: a susie posterior mean IS the + # 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) + asWeights <- readTwasWeights(fm, weightStandardized = TRUE) + expect_s4_class(asWeights, "TwasWeights") + expect_equal( + as.numeric(resolveWeights(asWeights)$weights), + as.numeric( + S4Vectors::mcols( + topLoci(qtlFineMappingExample) + )$posterior_effect + )[order(variantIds( + readFineMappingResult(fm, weightStandardized = TRUE) + ))], + tolerance = 1e-8 + ) +}) + +# ---- the weight scale ----------------------------------------------------- + +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)) + # This fixture records the flag, so it reads without one. + expect_s4_class(readTwasWeights(path), "TwasWeights") + df <- utils::read.delim(path, check.names = FALSE) + df$weight_standardized <- NA + stripped <- .rdr_writeTable(df, "scale_stripped.bed") + expect_error( + readTwasWeights(stripped), + "publishes WGT but not `weight_standardized`" + ) + expect_s4_class( + readTwasWeights(stripped, weightStandardized = FALSE), + "TwasWeights" + ) +}) + +# ---- opt-in Wakefield log Bayes factors ------------------------------------ + +test_that("priorVariance derives log Bayes factors only when asked", { + df <- data.frame( + `#chr` = c("chr1", "chr1"), + start = c(99L, 199L), + end = c(100L, 200L), + ID = c("chr1:100:A:G", "chr1:200:C:T"), + PIP = c(0.9, 0.05), + ES = c(0.3, -0.1), + SE = c(0.05, 0.05), + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "wakefield.bed") + plain <- readFineMappingResult(path) + expect_true(all(is.na( + S4Vectors::mcols( + topLoci(plain, signalCutoff = 0) + )$logBF + ))) + derived <- readFineMappingResult(path, priorVariance = 0.04) + lbf <- S4Vectors::mcols(topLoci(derived, signalCutoff = 0))$logBF + expect_equal( + lbf, + .approxBayesFactor(df$ES / df$SE, df$SE, W = 0.04)$lbf, + tolerance = 1e-10 + ) + # Never silently over published values. + df$LBF <- c(5, 0) + withLbf <- .rdr_writeTable(df, "wakefield_has_lbf.bed") + expect_error( + readFineMappingResult(withLbf, priorVariance = 0.04), + "already carries LBF" + ) +}) + +test_that("priorVariance without a z or a standard error says so", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "wakefield_bare.bed") + expect_error( + readFineMappingResult(path, priorVariance = 0.04), + "publishes no z \\(EZ, or ES/SE\\)" + ) +}) + +# ---- EZ, and what it means -------------------------------------------------- + +test_that("EZ round-trips as a SUPPLIED z and is not invented", { + # The spec defines EZ as the z "provided if it was used to derive ES and + # SE". A z pecotmr computed as ES/SE must not come back claiming to be + # the source's, or a reader would believe ES/SE were derived. + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + ES = 0.3, + SE = 0.05, + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + noEz <- readFineMappingResult(.rdr_writeTable(df, "ez_no.bed")) + me <- marginalEffects(noEz) + expect_equal(as.numeric(me$z), 6, tolerance = 1e-8) + expect_false(any(as.logical(me$z_supplied))) + df$EZ <- 5.5 + withEz <- readFineMappingResult(.rdr_writeTable(df, "ez_yes.bed")) + me <- marginalEffects(withEz) + expect_equal(as.numeric(me$z), 5.5) + expect_true(all(as.logical(me$z_supplied))) +}) + +# ---- class choice, format choice, region ------------------------------------ + +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) + back <- readFineMappingResult(path, weightStandardized = TRUE) + expect_s4_class(back, "GwasFineMappingResult") + expect_equal( + .rdr_diff( + as.data.frame(topLoci(gwasFineMappingExample)), + as.data.frame(topLoci(back)) + ), + character(0) + ) +}) + +test_that("the format follows the extension unless it is named", { + expect_equal(pecotmr:::.prdFormat("x/y.bed.gz", "auto"), "bed") + expect_equal(pecotmr:::.prdFormat("x/y.tsv", "auto"), "bed") + expect_equal(pecotmr:::.prdFormat("x/y.vcf.gz", "auto"), "vcf") + expect_equal(pecotmr:::.prdFormat("x/y.bcf", "auto"), "vcf") + # A file named something else is read as whatever it is said to be. + expect_equal(pecotmr:::.prdFormat("x/y.txt", "vcf"), "vcf") +}) + +test_that("a tabix-indexed table can be read by region", { + data(qtlFineMappingExample, envir = environment()) + path <- .rdr_tmp("region.bed.gz") + exportToBed(qtlFineMappingExample, path) + all <- readFineMappingResult(path, weightStandardized = TRUE) + full <- topLoci(all, signalCutoff = 0) + window <- GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(full))[[1L]], + IRanges::IRanges( + start = GenomicRanges::start(full)[[1L]], + end = GenomicRanges::start(full)[[3L]] + ) + ) + part <- readFineMappingResult( + path, + region = window, + weightStandardized = TRUE + ) + expect_lt(length(variantIds(part)), length(variantIds(all))) + expect_true(all(is_in(variantIds(part), variantIds(all)))) +}) + +test_that("an un-indexed file ignores a region loudly", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + path <- .rdr_writeTable(df, "noindex.bed") + expect_warning( + readFineMappingResult(path, region = "chr1:1-1000"), + "not bgzipped \\+ tabix-indexed" + ) +}) + +test_that("a missing file names itself", { + expect_error( + readFineMappingResult(.rdr_tmp("absent_xyz.bed")), + "does not exist" + ) +}) + +# ---- the ##SAMPLE key table ------------------------------------------------- + +test_that("every ##SAMPLE key is alphanumeric", { + # Rsamtools' header parser splits the `<...>` on `,(?=[[:alnum:]]+=)`, so + # an underscored key is not recognised as a key at all: it glues onto the + # previous value and every field after it on the line is lost. Six of + # these were unreadable for that reason. + keys <- pecotmr:::.PUB_SAMPLE_KEYS + expect_true(all(str_detect(keys, "^[A-Za-z0-9]+$"))) + expect_equal(length(unique(keys)), length(keys)) +}) + +test_that("a per-fit field with no ##SAMPLE key stops the writer", { + expect_error( + pecotmr:::.pubSampleKeys(c("study", "brand_new_field")), + "brand_new_field.*no\\s+##SAMPLE key" + ) +}) + +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)) + # 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( + c("study", "context", "trait", "method", "region_start", "cs_index"), + colnames(meta) + ))) + expect_equal(meta$method, "susie") +}) + +test_that("a header-only file reads back as an empty collection", { + # An export of a result whose every entry was screened out writes its + # schema and no rows. That is a legitimate file, so it reads as an empty + # collection rather than erroring about identity axes it has no rows to + # record. + header <- str_flatten(pecotmr:::.pubSchema(character(0)), "\t") + path <- .rdr_tmp("empty.bed") + writeLines(header, path) + back <- readFineMappingResult(path) + expect_s4_class(back, "QtlFineMappingResult") + expect_equal(nrow(back), 0L) + weights <- readTwasWeights(path) + expect_s4_class(weights, "TwasWeights") + expect_equal(nrow(weights), 0L) +}) + +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) + expect_equal(nrow(readFineMappingResult(path)), 0L) +}) + +# --------------------------------------------------------------------------- +# The VCF reader's edge paths +# --------------------------------------------------------------------------- + +# A published VCF, bgzipped and tabix-indexed so it can be read by region. +# @noRd +.rdr_indexedVcf <- function(x, name, ...) { + plain <- .rdr_tmp(name) + exportToVcf(x, plain, ...) + gz <- Rsamtools::bgzip(plain, dest = str_c(plain, ".gz"), overwrite = TRUE) + Rsamtools::indexTabix(gz, format = "vcf") + gz +} + +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) + full <- topLoci(all, signalCutoff = 0) + window <- GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(full))[[1L]], + IRanges::IRanges( + start = GenomicRanges::start(full)[[1L]], + end = GenomicRanges::start(full)[[5L]] + ) + ) + part <- readFineMappingResult( + gz, + region = window, + weightStandardized = TRUE + ) + expect_lt(length(variantIds(part)), length(variantIds(all))) + expect_true(all(is_in(variantIds(part), variantIds(all)))) + # The window still carries the analysis region from the ##SAMPLE header, + # which is per-fit and does not shrink with the variants read. + expect_equal(genomicRegion(part), genomicRegion(all)) +}) + +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" + ) + back <- readFineMappingResult( + gz, + region = "chrZZ:1-1000", + weightStandardized = TRUE, + studyName = "s", + context = "c", + trait = "t", + method = "susie" + ) + expect_equal(nrow(back), 0L) +}) + +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") + expect_warning( + readFineMappingResult( + path, + region = "chr22:1-1000000", + weightStandardized = TRUE + ), + "not bgzipped \\+ tabix-indexed" + ) +}) + +test_that("a missing VCF names itself before VariantAnnotation is asked", { + skip_if_not_installed("VariantAnnotation") + expect_error( + readFineMappingResult(.rdr_tmp("absent_xyz.vcf")), + "does not exist" + ) +}) + +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) + both <- readFineMappingResult(path, weightStandardized = TRUE) + expect_equal(nrow(both), 2L) + samples <- VariantAnnotation::samples( + VariantAnnotation::scanVcfHeader(path) + ) + one <- readFineMappingResult( + path, + sampleSelect = samples[[1L]], + weightStandardized = TRUE + ) + expect_equal(nrow(one), 1L) + expect_error( + readFineMappingResult(path, sampleSelect = "not-a-sample"), + "sampleSelect names not-a-sample, which the VCF does not have" + ) +}) + +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") + stripped <- .rdr_tmp("nosample_stripped.vcf") + lines <- readLines(path) + writeLines(lines[!str_starts(lines, "##SAMPLE=")], stripped) + # Without the header the file records no method either, so the reader asks + # for the one axis it cannot invent. + expect_error( + readFineMappingResult(stripped, weightStandardized = TRUE), + "does not record method" + ) + back <- readFineMappingResult( + stripped, + method = "susie", + weightStandardized = TRUE + ) + # Splitting the sample name into a tuple would be guesswork; taking it + # whole keeps each sample a result of its own. + expect_s4_class(back, "GwasFineMappingResult") + expect_match(studyName(back), "\\|") + # No header means no partial fit to restore either. + expect_null(susieFit(back)) +}) + +# --------------------------------------------------------------------------- +# Published-table edge paths +# --------------------------------------------------------------------------- + +test_that("a table with start but no end still locates its variants", { + # `end` is the 1-based position of a half-open single-base record, and + # `start + 1` says the same thing -- a table carrying only `start` is + # still readable. + df <- data.frame( + `#chr` = "chr1", + start = 99L, + ID = "chr1:100:A:G", + PIP = 0.9, + study = "s", + context = "c", + trait = "t", + method = "susie", + check.names = FALSE + ) + back <- readFineMappingResult(.rdr_writeTable(df, "startonly.bed")) + expect_equal(variantIds(back), "chr1:100:A:G") +}) + +test_that("an identity-less header-only file reads as an empty GWAS result", { + # No context or trait column at all, so the GWAS branch of the empty path. + writeLines( + str_flatten(c("#chr", "start", "end", "ID", "PIP"), "\t"), + .rdr_tmp("empty_gwas.bed") + ) + back <- readFineMappingResult(.rdr_tmp("empty_gwas.bed")) + expect_s4_class(back, "GwasFineMappingResult") + expect_equal(nrow(back), 0L) +}) + +test_that("a weights file read with no WGT column points at the other reader", { + df <- data.frame( + `#chr` = "chr1", + start = 99L, + end = 100L, + ID = "chr1:100:A:G", + PIP = 0.9, + check.names = FALSE + ) + expect_error( + readTwasWeights(.rdr_writeTable(df, "nowgt.bed")), + "no `WGT` column.*readFineMappingResult" + ) +}) + +test_that("a region id with no underscores falls back to the variants' chrom", { + expect_equal( + .prdRegionChrom( + data.frame( + region_id = "noUnderscores", + `#chr` = "chr7", + check.names = FALSE + ), + 1L, + "x" + ), + "chr7" + ) + # Nothing to go on at all. + expect_true(is.na(.prdRegionChrom(data.frame(a = 1), 1L, "x"))) +}) + +test_that("a packed header value unpacks, and an absent one is NULL", { + expect_equal(.prdUnpackNumeric(list("1;2;3")), c(1, 2, 3)) + expect_null(.prdUnpackNumeric(NULL)) + expect_null(.prdUnpackNumeric(list(NA_character_))) + expect_null(.prdUnpackNumeric(list(""))) +}) + +# --------------------------------------------------------------------------- +# Headers sparser than the writer's own +# --------------------------------------------------------------------------- + +# A published VCF whose `##SAMPLE` block is replaced wholesale, keeping the +# sample `ID` so the block still belongs to the sample. A file written by an +# older pecotmr -- or by anything else following the GWAS-VCF spec -- carries +# fewer keys than today's writer, and the reader has to work from whatever is +# 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") + lines <- readLines(path) + at <- which(str_starts(lines, "##SAMPLE=")) + expect_length(at, 1L) + id <- str_match(lines[[at]], "ID=([^,>]+)")[, 2L] + lines[[at]] <- str_c("##SAMPLE=") + out <- .rdr_tmp(str_c(name, ".vcf")) + writeLines(lines, out) + list(path = out, sample = id) +} + +test_that("a ##SAMPLE block with no identity keys reads as one study", { + skip_if_not_installed("VariantAnnotation") + f <- .rdr_reheaderedVcf("noident", "TotalVariants=3") + # Nothing in the header maps to an identity axis, so the sample name is + # the only study there is -- and method, which cannot be invented, has to + # be supplied. + expect_error( + readFineMappingResult(f$path, weightStandardized = TRUE), + "does not record method" + ) + back <- readFineMappingResult( + f$path, + method = "susie", + weightStandardized = TRUE + ) + expect_s4_class(back, "GwasFineMappingResult") + expect_equal(studyName(back), f$sample) + # A header carrying neither V nor CsIndex restores no partial fit. + expect_null(susieFit(back)) +}) + +test_that("a ##SAMPLE block with no RegionStart still reads", { + skip_if_not_installed("VariantAnnotation") + f <- .rdr_reheaderedVcf( + "noregion", + "Study=s1,Context=c1,Trait=t1,Method=susie" + ) + back <- readFineMappingResult(f$path, weightStandardized = TRUE) + expect_equal(as.character(back$study), "s1") + expect_equal(as.character(back$method), "susie") + # The window is the span of the variants the file holds, because the + # header recorded no analysis region to prefer over it. + rg <- genomicRegion(back) + expect_equal(start(rg), min(IRanges::start(back[[1L]]))) + expect_null(susieFit(back)) +}) + +# A header or data line trimmed to the eight fixed VCF columns. +# @noRd +.rdr_dropSampleColumns <- function(line) { + if (str_starts(line, "##")) { + return(line) + } + str_flatten(str_split_1(line, "\t")[1:8], "\t") +} + +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) + 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. + sites <- map_chr(lines[keep], .rdr_dropSampleColumns) + out <- .rdr_tmp("sites.vcf") + writeLines(sites, out) + # Naming the real problem: the earlier behaviour was to hand back an + # empty table, which failed further in with "no `PIP` column". + expect_error( + readFineMappingResult(out, method = "susie"), + "the VCF has no samples" + ) + expect_error(readTwasWeights(out), "the VCF has no samples") +}) diff --git a/tests/testthat/test_resultWriters.R b/tests/testthat/test_resultWriters.R new file mode 100644 index 00000000..a263d443 --- /dev/null +++ b/tests/testthat/test_resultWriters.R @@ -0,0 +1,2160 @@ +# Tests for the published result writers (resultWriters.R): exportToVcf, the +# GWAS-VCF-style writer, and exportToBed, the published long-format tables. + +# ============================================================================= +# Test data helpers +# ============================================================================= + +makeTestGenotypeHandle <- function() { + new( + "GenotypeHandle", + path = "/tmp/test.gds", + format = "gds", + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ) +} + +makeTestGwasSumStats <- function(n = 5) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = seq(100, by = 100, length.out = n), width = 1) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = paste0("rs", seq_len(n)), + A1 = rep("A", n), + A2 = rep("T", n), + Z = seq(1.5, by = -0.5, length.out = n), + N = rep(1000L, n) + ) + GwasSumStats( + studyName = "test_trait", + entry = list(gr), + genome = "hg38", + ldSketch = makeTestGenotypeHandle() + ) +} + +makeTestFineMappingResult <- function(n = 5) { + beta <- seq(0.5, by = -0.1, length.out = n) + se <- rep(0.1, n) + zv <- seq(5.0, by = -1.0, length.out = n) + tl <- data.frame( + variant_id = paste0( + "chr1:", + seq(100, by = 100, length.out = n), + ":T:A" + ), + chrom = rep("1", n), + pos = as.integer(seq(100, by = 100, length.out = n)), + A1 = rep("A", n), + A2 = rep("T", n), + N = rep(1000, n), + MAF = rep(0.1, n), + marginal_beta = beta, + marginal_se = se, + marginal_z = zv, + marginal_p = 2 * pnorm(-abs(zv)), + pip = seq(0.9, by = -0.1, length.out = n), + posterior_mean = beta * 0.5, + posterior_sd = se * 0.5, + cs_95 = paste0("susie_", c(1L, 1L, 0L, 2L, 0L)[seq_len(n)]), + method = rep("susie", n), + stringsAsFactors = FALSE + ) + entry <- fineMappingRow( + variantIds = tl$variant_id, + susieFit = list(), + topLoci = tl + ) + GwasFineMappingResult( + studyName = "test_study", + method = "susie", + entry = list(entry) + ) +} + +# ============================================================================= +# 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) +}) + +# ============================================================================= +# FineMappingResult to VCF +# ============================================================================= + +test_that("exportToVcf writes FineMappingResult to uncompressed VCF", { + 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) + 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. + expect_true(any(grepl("ID=PIP,", ln, fixed = TRUE))) + expect_true(any(grepl("ID=CS95,", ln, fixed = TRUE))) + data1 <- ln[!grepl("^#", ln)][[1L]] + fmtKeys <- strsplit(strsplit(data1, "\t")[[1L]][[9L]], ":")[[1L]] + expect_true("PIP" %in% fmtKeys) + expect_true("CS95" %in% fmtKeys) + # cs_95 "susie_" -> integer CS index; fixture row 1 is in CS 1. + vals <- strsplit(strsplit(data1, "\t")[[1L]][[10L]], ":")[[1L]] + expect_equal(vals[[which(fmtKeys == "CS95")]], "1") +}) + +# ============================================================================= +# FineMappingResult to BCF +# ============================================================================= + +test_that("exportToVcf writes FineMappingResult to BCF", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + skip_if_not_installed("Rsamtools") + + # asBcf may be temporarily disabled in some Rsamtools versions + asbcf_works <- tryCatch( + { + tmp_stem <- tempfile(fileext = ".vcf") + tmp_bgz <- paste0(tmp_stem, ".bgz") + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = 100, width = 1, names = "chr1:100:A:G") + ) + hdr <- VariantAnnotation::VCFHeader( + header = IRanges::DataFrameList( + fileformat = S4Vectors::DataFrame( + Value = "VCFv4.2", + row.names = "fileformat" + ) + ), + sample = "probe" + ) + cd <- S4Vectors::DataFrame(Samples = "probe", row.names = "probe") + v <- VariantAnnotation::VCF( + rowRanges = gr, + colData = cd, + exptData = list(header = hdr) + ) + VariantAnnotation::ref(v) <- Biostrings::DNAStringSet("A") + VariantAnnotation::alt(v) <- Biostrings::DNAStringSetList(list("T")) + VariantAnnotation::fixed(v)$FILTER <- "PASS" + VariantAnnotation::writeVcf(v, tmp_stem, index = TRUE) + bcf_stem <- tempfile() + Rsamtools::asBcf( + tmp_bgz, + dictionary = "chr1", + destination = bcf_stem + ) + TRUE + }, + error = function(e) FALSE + ) + skip_if(!asbcf_works, "Rsamtools::asBcf is not functional in this build") + + fm <- makeTestFineMappingResult(5) + out <- tempfile(fileext = ".bcf") + 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) +}) + +# ============================================================================= +# Empty FineMappingResult errors +# ============================================================================= + +test_that("exportToVcf errors on empty FineMappingResult", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + + empty_tl <- data.frame( + variant_id = character(0), + chrom = character(0), + pos = integer(0), + A1 = character(0), + A2 = character(0), + N = numeric(0), + MAF = numeric(0), + marginal_beta = numeric(0), + marginal_se = numeric(0), + marginal_z = numeric(0), + marginal_p = numeric(0), + pip = numeric(0), + posterior_mean = numeric(0), + posterior_sd = numeric(0), + stringsAsFactors = FALSE + ) + entry <- fineMappingRow( + variantIds = character(0), + susieFit = list(), + topLoci = empty_tl + ) + fm_empty <- GwasFineMappingResult( + studyName = "test_study", + method = "susie", + entry = list(entry) + ) + + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + + expect_error(exportToVcf(fm_empty, out), "no variants to write") +}) + +# ============================================================================= +# splitByContext / splitByTrait — one file per tuple +# ============================================================================= + +.makeMultiTupleQtlFmr <- function() { + contexts <- c("brain", "blood") + traits <- c("ENSG_A", "ENSG_B") + entries <- map(seq_along(contexts), function(i) { + ids <- paste0("chr1:", 100 * (1:3), ":T:A") + tl <- data.frame( + variant_id = ids, + chrom = rep("1", 3), + pos = c(100L, 200L, 300L), + A1 = rep("A", 3), + A2 = rep("T", 3), + N = rep(1000, 3), + MAF = rep(0.1, 3), + marginal_beta = c(0.3, 0.1, -0.2) + i / 100, + marginal_se = rep(0.05, 3), + marginal_z = c(6.0, 2.0, -4.0), + marginal_p = c(1e-9, 0.045, 6e-5), + pip = c(0.9, 0.5, 0.7), + posterior_mean = rep(0.05, 3), + posterior_sd = rep(0.02, 3), + cs_95 = paste0("susie_", c(1L, 1L, 0L)), + stringsAsFactors = FALSE + ) + fineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) + }) + QtlFineMappingResult( + studyName = rep("study1", 2), + context = contexts, + trait = traits, + method = rep("susie", 2), + entry = entries + ) +} + +test_that("exportToVcf(FineMapping): splitByContext 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, 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)) + } +}) + +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", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + fmr <- .makeMultiTupleQtlFmr() + out <- tempfile(fileext = ".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) + lines <- readLines(out) + header <- str_split(lines[str_starts(lines, "#CHROM")][[1L]], "\t")[[1L]] + samples <- header[-seq_len(9L)] + expect_length(samples, 2L) + # each sample is named for the fit it came from, and described in a + # ##SAMPLE header line + expect_true(all(str_detect(samples, "\\|"))) + sampleLines <- keep(lines, str_starts, "##SAMPLE=") + expect_length(sampleLines, 2L) + expect_true(all(str_detect(sampleLines, "TotalVariants="))) + # one record per variant, with a cell per sample + body <- str_split(lines[!str_starts(lines, "#")][[1L]], "\t")[[1L]] + expect_length(body, 9L + 2L) +}) + +test_that("exportToVcf(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 + # sample is empty where its own fit had nothing. + mk <- function(positions, ctx) { + ids <- sprintf("chr1:%d:T:A", positions) + tl <- data.frame( + variant_id = ids, + chrom = rep("1", length(ids)), + pos = as.integer(positions), + A1 = "A", + A2 = "T", + pip = seq(0.9, by = -0.1, length.out = length(ids)), + cs_95 = "susie_1", + method = "susie", + stringsAsFactors = FALSE + ) + QtlFineMappingResult( + studyName = "s1", + context = ctx, + trait = "g1", + method = "susie", + entry = list(fineMappingRow( + variantIds = ids, + susieFit = list(), + topLoci = tl + )) + ) + } + fmr <- combineFineMappingResults(mk(c(100, 200), "a"), mk(c(300), "b")) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + exportToVcf(fmr, out) + lines <- readLines(out) + cells <- str_split(keep(lines, str_starts, "chr1"), "\t") + expect_identical(map_chr(cells, 2L), c("100", "200", "300")) + keys <- str_split(cells[[1L]][[9L]], ":")[[1L]] + pipOf <- function(cell) str_split(cell, ":")[[1L]][[which(keys == "PIP")]] + # sample 1 covers 100/200, sample 2 only 300 + expect_identical(map_chr(map(cells, 10L), pipOf), c("0.9", "0.8", ".")) + expect_identical(map_chr(map(cells, 11L), pipOf), c(".", ".", "0.9")) +}) + +# ============================================================================= +# GwasSumStats: multi-study selection, MAF/AF field, .gz rename +# ============================================================================= + +.makeTwoStudyGwasSumStats <- function(n = 3, withMaf = FALSE) { + mkGr <- function() { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = seq(100, by = 100, length.out = n), + width = 1 + ) + ) + mc <- S4Vectors::DataFrame( + SNP = paste0("rs", seq_len(n)), + A1 = rep("A", n), + A2 = rep("T", n), + Z = seq(1.5, by = -0.5, length.out = n), + N = rep(1000L, n) + ) + if (withMaf) { + mc$MAF <- rep(0.2, n) + } + S4Vectors::mcols(gr) <- mc + gr + } + GwasSumStats( + studyName = c("studyA", "studyB"), + entry = list(mkGr(), mkGr()), + genome = "hg38", + ldSketch = makeTestGenotypeHandle() + ) +} + +test_that("exportToVcf(SumStats): multi-study needs a `study`", { + skip_if_not_installed("VariantAnnotation") + ss2 <- .makeTwoStudyGwasSumStats() + out <- tempfile(fileext = ".vcf") + expect_error(exportToVcf(ss2, out), "2 studies") +}) + +test_that("exportToVcf(SumStats): `study` 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") + expect_equal(res, out) + expect_true(file.exists(out)) +}) + +test_that("exportToVcf(SumStats): emits AF when MAF is present", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + ss <- GwasSumStats( + studyName = "t", + entry = list(local({ + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = c(100, 200, 300, 400), width = 1) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = paste0("rs", 1:4), + A1 = rep("A", 4), + A2 = rep("T", 4), + Z = c(1.5, 1.0, 0.5, 0.0), + N = rep(1000L, 4), + MAF = rep(0.2, 4) + ) + gr + })), + genome = "hg38", + ldSketch = makeTestGenotypeHandle() + ) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + exportToVcf(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 + # the ALTERNATIVE allele frequency, which a minor-allele frequency cannot + # be converted to -- it has lost which allele it refers to. + expect_true(any(grepl("ID=MAF", readLines(out)))) + expect_false(any(grepl("ID=AF,", readLines(out)))) +}) + +test_that("exportToVcf(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) + expect_equal(res, out) + # 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))) +}) + +# ============================================================================= +# FineMappingResult: explicit selectors, no-match error, composite/empty tags +# ============================================================================= + +test_that("exportToVcf(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( + fmr, + out, + studyName = "study1", + context = "brain", + trait = "ENSG_A", + method = "susie" + ) + expect_equal(res, out) + expect_true(file.exists(out)) +}) + +test_that("exportToVcf(FineMappingResult): 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"), + "no rows match" + ) +}) + +test_that("exportToVcf(FineMapping): split decorates a .vcf.bgz path", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + fmr <- .makeMultiTupleQtlFmr() + baseOut <- tempfile(fileext = ".vcf.bgz") + stem <- tools::file_path_sans_ext(tools::file_path_sans_ext(baseOut)) + on.exit( + unlink( + list.files( + dirname(baseOut), + pattern = basename(stem), + full.names = TRUE + ), + force = TRUE + ), + add = TRUE + ) + paths <- exportToVcf(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))) + expect_true(any(grepl("\\.brain\\.vcf\\.bgz$", paths))) + expect_true(any(grepl("\\.blood\\.vcf\\.bgz$", paths))) +}) + +test_that("exportToVcf(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 + # empty and the original output path is used unchanged. + fm <- makeTestFineMappingResult(5) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + paths <- exportToVcf(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`", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + # The marginal view projects allele frequency to a column named `af`, so a + # topLoci carrying `af` must surface as the AF genotype field. + n <- 3 + tl <- data.frame( + variant_id = paste0("chr1:", c(100, 200, 300), ":T:A"), + chrom = rep("1", n), + pos = c(100L, 200L, 300L), + A1 = rep("A", n), + A2 = rep("T", n), + N = rep(1000, n), + af = c(0.1, 0.2, 0.3), + marginal_beta = c(0.3, -0.2, 0.1), + marginal_se = rep(0.05, n), + marginal_z = c(6.0, -4.0, 2.0), + marginal_p = c(1e-9, 6e-5, 0.045), + pip = c(0.9, 0.7, 0.5), + posterior_mean = rep(0.05, n), + posterior_sd = rep(0.02, n), + cs_95 = paste0("susie_", c(1L, 0L, 2L)), + stringsAsFactors = FALSE + ) + entry <- fineMappingRow( + variantIds = tl$variant_id, + susieFit = list(), + topLoci = tl + ) + fm <- GwasFineMappingResult( + studyName = "s", + method = "susie", + entry = list(entry) + ) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + exportToVcf(fm, out) + expect_true(file.exists(out)) + expect_true(any(grepl("ID=AF", readLines(out)))) +}) + +test_that("exportToVcf(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 + # logBF (LBF), local false sign rate (LFSR), per-CS purity (PUR), + # and the wide fullFit + # columns (within_cs_pip / cs_logbf_ / cs_effect_). + n <- 3 + tl <- data.frame( + variant_id = paste0("chr1:", c(100, 200, 300), ":T:A"), + chrom = rep("1", n), + pos = c(100L, 200L, 300L), + A1 = rep("A", n), + A2 = rep("T", n), + N = rep(1000, n), + marginal_beta = c(0.3, -0.2, 0.1), + marginal_se = rep(0.05, n), + marginal_z = c(6, -4, 2), + marginal_p = c(1e-9, 6e-5, 0.045), + pip = c(0.9, 0.7, 0.5), + posterior_mean = rep(0.05, n), + posterior_sd = rep(0.02, n), + logBF = c(3.1, 1.2, 0.4), + lfsr = c(0.01, 0.2, 0.4), + cs_95 = paste0("susie_", c(1L, 0L, 2L)), + cs_95_purity = c(0.95, 0, 0.88), + within_cs_pip = c(0.6, 0, 0.5), + cs_logbf_susie_1 = c(2.2, NA, NA), + cs_effect_susie_1 = c(0.4, NA, NA), + stringsAsFactors = FALSE + ) + entry <- fineMappingRow( + variantIds = tl$variant_id, + susieFit = list(), + topLoci = tl + ) + fm <- GwasFineMappingResult( + studyName = "s", + method = "susie", + entry = list(entry) + ) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + exportToVcf(fm, out) + ln <- readLines(out) + for (id in c( + "ID=LBF", + "ID=LFSR", + "ID=PUR95", + "ID=WITHIN_CS_PIP", + "ID=CS_LOGBF_SUSIE_1", + "ID=CS_EFFECT_SUSIE_1" + )) { + expect_true(any(grepl(id, ln, fixed = TRUE)), info = id) + } +}) + +test_that("exportToVcf(FineMapping): falls back to marginal sumstats", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + fm <- makeTestFineMappingResult(5) + # Simulate an entry whose posterior table is unavailable (empty topLoci) so + # the marginal univariate sumstats alone drive the body (the else-if). + testthat::local_mocked_bindings( + topLoci = function(x, ...) GenomicRanges::GRanges(), + .package = "pecotmr" + ) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + exportToVcf(fm, out) + expect_true(file.exists(out)) + # marginal beta -> ES + expect_true(any(grepl("ID=ES", readLines(out), fixed = TRUE))) +}) + + +# =========================================================================== +# Output formats +# =========================================================================== + +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")) + expect_true(file.exists(file.path(d, "a.vcf"))) + exportToVcf( + gwasSumStatsS4Example, + outputPath = 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. + expect_true(file.exists(file.path(d, "b.vcf.bgz.tbi"))) +}) + +test_that("BCF output explains itself when Rsamtools cannot convert", { + # Rsamtools >= 2.26 raises "asBcf() is temporarily disabled". Left bare + # that surfaces as an opaque failure from a documented output format, so + # it is translated into the cause plus the workaround. + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Rsamtools") + data(gwasSumStatsS4Example) + d <- withr::local_tempdir() + canConvert <- !inherits( + tryCatch( + Rsamtools::asBcf("nonexistent", "x", "y"), + error = function(e) e + ), + "error" + ) + skip_if(canConvert, "Rsamtools::asBcf() works here; nothing to translate") + expect_error( + exportToVcf( + gwasSumStatsS4Example, + outputPath = file.path(d, "c.bcf") + ), + "BCF output needs a working Rsamtools::asBcf" + ) +}) + +test_that(".vcfResolveBody uses posterior rows when no marginals exist", { + local_mocked_bindings( + topLoci = function(entry, signalCutoff) { + # topLoci() returns ranges carrying the per-variant columns in + # mcols(); these ids are deliberately not coordinate-shaped, so + # the ranges are built directly rather than parsed from them. + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = c(1L, 2L), width = 1L) + ) + S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame( + variant_id = c("v1", "v2"), + pip = c(0.9, 0.1) + ) + ) + }, + marginalEffects = function(entry) stop("none"), + .package = "pecotmr" + ) + out <- pecotmr:::.vcfResolveBody("e", "S1") + expect_true(out$hasPost) + expect_equal(nrow(out$base), 2L) + # No marginal table to align against, so there is nothing to merge in. + expect_null(out$m) +}) + +test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { + skip_if_not_installed("VariantAnnotation") + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + geno <- matrix(c(1.5, -0.5), ncol = 1L, dimnames = list(NULL, "S1")) + header <- S4Vectors::DataFrame( + Number = "1", + Type = "Float", + Description = "Z score", + row.names = "Z" + ) + pecotmr:::.writeVcfImpl( + chrom = c("1", "1"), + pos = c(100L, 200L), + ref = c("A", "C"), + alt = c("G", "T"), + snpIds = c("rs1", "rs2"), + geno = list(Z = geno), + genoHeader = header, + sampleName = "S1", + outputPath = out + ) + body <- readLines(out) + body <- body[!startsWith(body, "#")] + expect_true(all(startsWith(body, "chr1\t"))) +}) + +# ============================================================================= +# exportToBed: the fine-mapping schemas +# ============================================================================= + +test_that("exportToBed writes the published top-loci schema", { + data(qtlFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + expect_identical( + exportToBed(qtlFineMappingExample, out, signalCutoff = 0), + out + ) + tbl <- utils::read.delim(out, check.names = FALSE) + # The whole schema, in order -- `context` is gone, `event_ID` already + # carried it, as in the other two schemas. + expect_identical( + names(tbl)[1:6], + c("#chr", "start", "end", "ID", "REF", "ALT") + ) + # One vocabulary with the VCF: the spec's keys for what it defines, ours + # alongside, snake_case for the per-fit fields. + expect_true(all(c("ES", "SE", "LP", "NS") %in% names(tbl))) + # EZ only when the source SUPPLIED z -- the spec defines it as the z used + # to derive ES/SE, and this fixture recorded beta/se instead. + expect_false("EZ" %in% names(tbl)) + expect_true(all(c("WGT", "WGTSE", "PIP", "LBF") %in% names(tbl))) + # coverage levels are discovered, not hardcoded + expect_true(all(c("CS95", "PUR95", "CS70", "CS50") %in% names(tbl))) + expect_true(all(c("study", "context", "trait", "method") %in% names(tbl))) + expect_true(all( + c("region_id", "region_start", "region_end") %in% names(tbl) + )) + # and the columns this input has nothing to say about are absent, not + # padded with NAs + expect_false(any(c("MAF", "weight_standardized") %in% names(tbl))) + expect_gt(nrow(tbl), 0L) + # sorted by (chr, pos) + first <- tbl[[1L]][[1L]] + expect_false(is.unsorted(tbl$start[tbl[[1L]] == first])) +}) + +test_that("exportToBed bgzips and tabix-indexes a .gz fsusie table", { + data(fsusieFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed.gz") + exportToBed(fsusieFineMappingExample, out, schema = "fsusie") + expect_true(file.exists(out)) + expect_true(file.exists(str_c(out, ".tbi"))) + hdr <- readLines(gzfile(out), n = 1L) + cols <- str_split(hdr, "\t")[[1L]] + expect_identical(cols[[1L]], "#chr") + # 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( + c( + "grid_positions", + "grid_effects", + "grid_band_halfwidth", + "joint_traits", + "region_start", + "region_end" + ) %in% + cols + )) +}) + +test_that("exportToBed 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) + lines <- readLines(out) + expect_length(lines, 1L) + # A header-only file documents the whole vocabulary rather than + # collapsing to the required core. + hdr <- str_split(lines[[1L]], "\t")[[1L]] + expect_identical(hdr[1:6], c("#chr", "start", "end", "ID", "REF", "ALT")) + expect_true(all(c("ES", "WGT", "PIP", "region_id") %in% hdr)) +}) + +test_that("exportToBed 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( + list(qtlFineMappingExample, mvsusieFineMappingExample), + both, + signalCutoff = 0 + ) + n1 <- length(readLines(one)) + n2 <- length(readLines(both)) + # One header either way, and the combined table carries strictly more rows. + expect_gt(n2, n1) + tbl <- utils::read.delim(both, check.names = FALSE) + expect_setequal( + unique(tbl$context), + unique(c( + as.character(contexts(qtlFineMappingExample)), + as.character(contexts(mvsusieFineMappingExample)) + )) + ) +}) + +test_that("exportToBed rejects a non-FineMappingResult", { + out <- withr::local_tempfile(fileext = ".bed") + expect_error(exportToBed(data.frame(a = 1), out), "FineMappingResult") + expect_error(exportToBed(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") + lines <- readLines(out) + expect_length(lines, 1L) + # a header-only file documents the schema, with no coverage discovered + expect_identical( + str_split(lines[[1L]], "\t")[[1L]], + .fmbFsusieColumns(c("wavelet", "trait")) + ) +}) + +test_that("a merged multi-region fSuSiE table keeps each region's own window", { + data(fsusieFineMappingExample) + a <- fsusieFineMappingExample + b <- fsusieFineMappingExample + # Two regions whose (context, cs) labels collide -- the case a + # context+cs key would silently merge onto the first region's window. + S4Vectors::mcols(b)$study <- "studyB" + wantA <- GenomicRanges::GRanges("chr22:1-9000000") + wantB <- GenomicRanges::GRanges("chr22:2-8000000") + withRegion <- function(x, want) { + S4Vectors::mcols(x)$region <- rep(want, nrow(x)) + x + } + both <- combineFineMappingResults( + withRegion(a, wantA), + withRegion(b, wantB) + ) + out <- withr::local_tempfile(fileext = ".bed.gz") + exportToBed(both, out, schema = "fsusie") + tbl <- utils::read.delim(gzfile(out), check.names = FALSE) + expect_setequal( + unique(tbl$region_id), + c("chr22_1_9000000", "chr22_2_8000000") + ) + expect_setequal(unique(tbl$region_start), c(0, 1)) + expect_setequal(unique(tbl$region_end), c(9000000, 8000000)) +}) + +test_that("extraColumns appends trailing fields the object cannot know", { + data(qtlFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + extraColumns = list(source_file = "chr22_1_50000000") + ) + tbl <- utils::read.delim(out, check.names = FALSE) + expect_identical(names(tbl)[[ncol(tbl)]], "source_file") + expect_true(all(tbl$source_file == "chr22_1_50000000")) + + # one value per row is equally valid + perRow <- withr::local_tempfile(fileext = ".bed") + exportToBed( + qtlFineMappingExample, + perRow, + signalCutoff = 0, + extraColumns = list(tag = seq_len(nrow(tbl))) + ) + expect_identical( + utils::read.delim(perRow, check.names = FALSE)$tag, + seq_len(nrow(tbl)) + ) +}) + +test_that("extraColumns refuses a clash, a bad length, an unnamed list", { + data(qtlFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + expect_error( + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + extraColumns = list(PIP = 1) + ), + "would overwrite" + ) + expect_error( + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + extraColumns = list(tag = c(1, 2)) + ), + "one value per row" + ) + expect_error( + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + extraColumns = list(1) + ), + "NAMED list" + ) +}) + +test_that("extraColumns survive an empty table", { + data(qtlFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 2, + extraColumns = list(source_file = "b1") + ) + lines <- readLines(out) + expect_length(lines, 1L) + expect_identical( + str_split(lines[[1L]], "\t")[[1L]], + c(str_split(readLines(out)[[1L]], "\t")[[1L]]) + ) +}) + +test_that("genomicOrder sorts chromosomes naturally, not as text", { + # 1..22 numerically, then the non-numeric contigs after all of them -- + # `sort -k1,1V` order, where 2 precedes 10. + expect_identical( + genomicOrder(c("10", "2", "X", "1"), c(1, 1, 1, 1)), + c(4L, 2L, 1L, 3L) + ) + expect_identical( + genomicOrder(c("chr10", "chrX", "chr2", "chrY", "chr22"), rep(1, 5)), + c(3L, 1L, 5L, 2L, 4L) + ) + # a leading "chr" is cosmetic + expect_identical( + genomicOrder(c("chr2", "10"), c(1, 1)), + genomicOrder(c("2", "chr10"), c(1, 1)) + ) + # positions sort numerically within a chromosome, not as text + expect_identical( + genomicOrder(rep("chr1", 3L), c("100", "9", "1000")), + c(2L, 1L, 3L) + ) + # a single chromosome is the common case and must be a no-op + expect_identical(genomicOrder(rep("chr22", 3L), c(1, 2, 3)), 1:3) +}) + +test_that("genomicOrder uses `end` only to break ties, and only if numeric", { + chrom <- rep("chr1", 3L) + start <- c(10, 10, 5) + expect_identical( + genomicOrder(chrom, start, end = c(90, 20, 1)), + c(3L, 2L, 1L) + ) + # A third column that is not a position (an allele) is ignored rather than + # coerced to NA and allowed to scramble the order. + expect_identical( + genomicOrder(chrom, start, end = c("A", "T", "G")), + genomicOrder(chrom, start) + ) + expect_identical( + genomicOrder(chrom, start, end = NULL), + genomicOrder(chrom, start) + ) +}) + +# ============================================================================= +# exportToBed: the TWAS-weight schemas +# ============================================================================= + +makeTestTwasWeights <- function(weights, method = "lasso", nVariants = 3L) { + ids <- sprintf("chr1:%d:A:G", 100L * seq_len(nVariants)) + TwasWeights( + studyName = "s1", + context = "brain", + trait = "g1", + method = method, + entry = list(twasWeightsRow( + variantIds = ids, + weights = weights, + cvResult = list(metrics = c(rsq = 0.5, pval = 0.01)), + weightStandardized = TRUE + )) + ) +} + +test_that("exportToBed writes the published TWAS-weight schema", { + data(twasWeightsExample) + out <- withr::local_tempfile(fileext = ".bed") + expect_identical(exportToBed(twasWeightsExample, out), out) + tbl <- utils::read.delim(out, check.names = FALSE) + expect_identical( + names(tbl)[1:6], + c("#chr", "start", "end", "ID", "REF", "ALT") + ) + expect_true(all( + c("WGT", "weight_standardized", "data_type") %in% names(tbl) + )) + # the posterior columns a weights table has nothing to say about are gone + expect_false(any(c("PIP", "LBF", "CS95") %in% names(tbl))) + # one row per (model, variant): 168 variants each + # 2 of the 11 rows are fine-mapping-derived and are skipped + expect_identical(nrow(tbl), 9L * 168L) + expect_setequal( + unique(tbl$method), + setdiff( + as.character(S4Vectors::mcols(twasWeightsExample)$method), + .TWB_FINE_MAPPING_METHODS + ) + ) + expect_true(all(tbl$end == tbl$start + 1L)) + expect_false(is.unsorted(tbl$start)) + expect_true(all(tbl$gene_ID == "ENSG00000130538")) + # the analysis window, not the per-variant position + expect_identical(unique(tbl$region_end), 18850784L) +}) + +test_that("exportToBed 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) + tbl <- utils::read.delim(out, check.names = FALSE) + expect_identical(nrow(tbl), 6L) + expect_setequal(unique(tbl$trait), c("mark_a", "mark_b")) + expect_identical( + tbl$WGT[tbl$trait == "mark_b"], + c(-0.4, -0.5, -0.6) + ) + # 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) + 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", { + data(twasWeightsExample) + out <- withr::local_tempfile(fileext = ".bed.gz") + exportToBed(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]] + expect_true(all(c("#chr", "start", "end", "ID", "WGT") %in% cols)) +}) + +test_that("exporting refuses a TwasWeights with no full-data fit", { + # twasWeightsPipeline(fitFullData = FALSE) leaves each row an empty + # element with no weights and only a cvResult. Fold-level results cannot + # be published, so that is an error rather than an empty output file. + cvOnly <- TwasWeights( + studyName = "s1", + context = "brain", + trait = "g1", + method = "susie", + 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( + exportToVcf(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") + # and a weightless-but-populated row is refused for the same reason + expect_error( + exportToBed(makeTestTwasWeights(NULL), out), + "no full-data fit" + ) +}) + +test_that("exporting refuses a FineMappingResult row with no fitted variants", { + # Fine-mapping has no CV-only mode -- CV is attached on top of the fit -- + # but the export checks rather than assumes it. + fmr <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "g1", + method = "susie", + 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") +}) + +test_that("exportToBed 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) + 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", { + out <- withr::local_tempfile(fileext = ".bed") + expect_error(exportToBed(list(), out), "at least one") + expect_error( + exportToBed(list(1, 2), out), + "TwasWeights or FineMappingResult" + ) +}) + +# ============================================================================= +# exportToVcf: TWAS weights +# ============================================================================= + +test_that("exportToVcf writes TWAS weights with one sample per model", { + data(twasWeightsExample) + out <- withr::local_tempfile(fileext = ".vcf") + exportToVcf(twasWeightsExample, out) + lines <- readLines(out) + header <- str_split( + lines[str_starts(lines, "#CHROM")][[1L]], + "\t" + )[[1L]] + samples <- header[-seq_len(9L)] + # Nine of the eleven rows: the two fine-mapping-derived ones are skipped, + # the same as on the BED path. + expect_length(samples, 9L) + expect_true(all(str_detect(samples, "^s|protocol_example\\|bulk_rnaseq"))) + expect_true(any(str_detect(lines, "ID=WGT"))) + expect_identical(sum(!str_starts(lines, "#")), 168L) + # the per-variant FORMAT column is the weight, one value per sample + body <- str_split(lines[!str_starts(lines, "#")][[1L]], "\t")[[1L]] + expect_identical(body[[9L]], "WGT") + expect_length(body, 9L + 9L) +}) + +test_that("the TWAS-weight VCF describes each model in a ##SAMPLE line", { + data(twasWeightsExample) + out <- withr::local_tempfile(fileext = ".vcf") + exportToVcf(twasWeightsExample, out) + sampleLines <- keep(readLines(out), str_starts, "##SAMPLE=") + expect_length(sampleLines, 9L) + 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")) +}) + +test_that("exportToVcf narrows TWAS models with the identity selectors", { + data(twasWeightsExample) + out <- withr::local_tempfile(fileext = ".vcf") + exportToVcf(twasWeightsExample, out, method = "lasso") + lines <- readLines(out) + header <- str_split( + lines[str_starts(lines, "#CHROM")][[1L]], + "\t" + )[[1L]] + expect_length(header[-seq_len(9L)], 1L) + expect_error( + exportToVcf(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( + twasWeightsExample, + out, + method = "susie" + )), + "every selected row is fine-mapping-derived" + ) +}) + +test_that("exportToVcf 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") + lines <- readLines(out) + header <- str_split( + lines[str_starts(lines, "#CHROM")][[1L]], + "\t" + )[[1L]] + expect_identical(header[[10L]], "my_model") + expect_error( + exportToVcf(tw, out, sampleName = c("a", "b")), + "one name per model" + ) +}) + +test_that("a TWAS-weight VCF unions the variants its models disagree on", { + a <- makeTestTwasWeights(c(0.1, 0.2, 0.3), method = "lasso") + b <- TwasWeights( + studyName = "s1", + context = "brain", + trait = "g1", + method = "enet", + 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) + body <- keep(readLines(out), str_starts, "chr1") + # union of {100,200,300} and {300,400} + expect_length(body, 4L) + cells <- str_split(body, "\t") + pos <- map_chr(cells, 2L) + expect_identical(pos, c("100", "200", "300", "400")) + # the model that skipped a variant leaves its cell empty + expect_identical(map_chr(cells, 10L), c("0.1", "0.2", "0.3", ".")) + expect_identical(map_chr(cells, 11L), c(".", ".", "0.7", "0.8")) +}) + +# ============================================================================= +# Shared layer +# ============================================================================= + +test_that(".vcfAltList keeps a non-DNA ALT allele out of a DNAStringSet", { + # VCF's "*" (a variant spanned by an upstream deletion) is a legal ALT but + # not a DNA letter, and DNAStringSet rejects it outright. + expect_s4_class(.vcfAltList(c("A", "GT")), "DNAStringSetList") + expect_s4_class(.vcfAltList(c("A", "*")), "CharacterList") + expect_s4_class(.vcfAltList(c("A", NA)), "CharacterList") +}) + +test_that(".pubIdentityKey keeps an absent axis from erasing the whole key", { + # str_c() propagates NA, so a GWAS row's missing trait would make the + # entire key NA -- and match() pairs NA with NA, joining unrelated rows. + df <- data.frame( + study = c("a", "b"), + trait = c(NA_character_, NA_character_), + variant_id = c("v1", "v1") + ) + keys <- .pubIdentityKey(df, .PUB_VARIANT_COLS) + expect_false(anyNA(keys)) + expect_false(keys[[1L]] == keys[[2L]]) +}) + +test_that(".pubJoinMarginals gives an NA row where no marginal exists", { + base <- data.frame(variant_id = c("v1", "v2")) + marg <- data.frame(variant_id = "v1", beta = 0.5) + joined <- .pubJoinMarginals(base, marg) + expect_identical(nrow(joined), 2L) + expect_identical(joined$beta, c(0.5, NA_real_)) +}) + +# ============================================================================= +# exportToBed: 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( + list(qtlFineMappingExample, mvsusieFineMappingExample), + out, + signalCutoff = 0 + ) + tbl <- utils::read.delim(out, check.names = FALSE) + # Without study_ID / method a folded table cannot say which fit a row + # came from, which is the whole point of folding several in. + expect_true(all(c("study", "method") %in% names(tbl))) + expect_setequal( + unique(tbl$method), + c( + as.character(qtlFineMappingExample$method), + as.character(mvsusieFineMappingExample$method) + ) + ) + # the marginal statistics are complete: N and p, not only z, and they + # are populated rather than present-but-empty. Only for the univariate + # rows -- mvSuSiE has no marginal sumstats at all, so its rows carry no + # betahat / sebetahat / z / N / p either, which is why these columns are + # NA-able rather than required. + expect_true(all(c("NS", "LP") %in% names(tbl))) + univariate <- tbl[tbl$method == "susie", , drop = FALSE] + expect_gt(nrow(univariate), 0L) + expect_false(anyNA(univariate$NS)) + # LP is -log10 p of the marginal test, so it inverts to a probability + expect_true(all(10^(-univariate$LP) > 0 & 10^(-univariate$LP) <= 1)) + expect_equal( + 10^(-univariate$LP), + 2 * pnorm(-abs(univariate$ES / univariate$SE)), + tolerance = 1e-6 + ) + expect_true(all(is.na(tbl$LP[tbl$method == "mvsusie"]))) + # purity at every coverage the schema reports a credible set for + expect_true(all(c("PUR95", "PUR70", "PUR50") %in% names(tbl))) + # a true half-open BED like the other two schemas, so one reader rule + # covers everything + expect_identical(names(tbl)[1:3], c("#chr", "start", "end")) + expect_true(all(tbl$end == tbl$start + 1L)) + # the analysis window travels with the row, so a read-back result does not + # silently fall back to the span of the surviving variants + expect_false(anyNA(tbl$region_ID)) + expect_true(all(tbl$region_start <= tbl$end)) +}) + +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") + 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 + expect_identical(fullCols[seq_along(baseCols)], baseCols) + # "all" is a request for whatever is there, so it stays subject to the + # drop-empty rule. Every remaining view column is empty in this fixture + # (`gene`, `event`, `grange_*`), so it appends nothing and never removes + # anything. An explicitly NAMED column is kept even when empty -- that is + # what the next test checks. + expect_identical(fullCols, baseCols) + # the range columns an as.data.frame() adds duplicate chr/pos, so they + # must not come back under a second name + expect_false(any(c("seqnames", "width", "strand") %in% fullCols)) +}) + +test_that("columns takes an explicit set, and refuses a bad one", { + data(qtlFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + columns = "grange_start" + ) + cols <- names(utils::read.delim(out, check.names = FALSE)) + expect_identical(cols[[length(cols)]], "grange_start") + expect_error( + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + columns = "not_a_column" + ), + "does not carry" + ) + expect_error( + exportToBed( + qtlFineMappingExample, + out, + signalCutoff = 0, + columns = "pip" + ), + "already writes" + ) +}) + +test_that("the fsusie schema carries its study and takes columns = 'all'", { + data(fsusieFineMappingExample) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(fsusieFineMappingExample, out, schema = "fsusie") + tbl <- utils::read.delim(out, check.names = FALSE) + expect_identical( + names(tbl), + setdiff( + .fmbFsusieColumns( + c("wavelet", "trait"), + c("CS95", "PUR95") + ), + "AF" + ) + ) + expect_false(anyNA(tbl$study)) + + full <- withr::local_tempfile(fileext = ".bed") + exportToBed( + fsusieFineMappingExample, + full, + schema = "fsusie", + columns = "all" + ) + fullCols <- names(utils::read.delim(full, check.names = FALSE)) + # "all" is additive: the published columns keep their place and the + # non-empty remainder of the credible-set view follows. + expect_identical(fullCols[seq_along(names(tbl))], names(tbl)) + 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( + fsusieFineMappingExample, + named, + schema = "fsusie", + columns = "cs_95_purity" + ) + namedCols <- names(utils::read.delim(named, check.names = FALSE)) + expect_identical(namedCols[[length(namedCols)]], "cs_95_purity") +}) + +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") + 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) { + out <- withr::local_tempfile( + fileext = ".bed", + .local_envir = parent.frame() + ) + exportToBed( + fsusieFineMappingExample, + out, + schema = "fsusie", + levels = lv + ) + utils::read.delim(out, check.names = FALSE) + } + wav <- read("wavelet") + tr <- read("trait") + both <- read(c("wavelet", "trait")) + + # each level keeps its own group and drops the other's + expect_true(all(.FMB_FSUSIE_WAVELET_COLUMNS %in% names(wav))) + expect_false(any(.FMB_FSUSIE_TRAIT_COLUMNS %in% names(wav))) + expect_true(all(.FMB_FSUSIE_TRAIT_COLUMNS %in% names(tr))) + expect_false(any( + .FMB_FSUSIE_WAVELET_COLUMNS %in% + names(wav) & + .FMB_FSUSIE_WAVELET_COLUMNS %in% names(tr) + )) + + # a strict subset: same rows, same order, columns removed not reordered + expect_identical(nrow(wav), nrow(both)) + expect_identical( + names(wav), + setdiff(names(both), .FMB_FSUSIE_TRAIT_COLUMNS) + ) + expect_identical( + names(tr), + setdiff(names(both), .FMB_FSUSIE_WAVELET_COLUMNS) + ) + expect_identical(wav$cs_id, both$cs_id) + expect_identical(wav$grid_effects, both$grid_effects) + + expect_error( + exportToBed( + fsusieFineMappingExample, + withr::local_tempfile(), + schema = "fsusie", + levels = "nope" + ), + "wavelet" + ) +}) + +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 +# +# The spec defines EZ as the z "provided if it was used to derive the ES and +# SE fields". The fine-mapping writer already obeyed that through +# `.pubEz()`; this writer published any `Z` column it found, so a Wald z that +# pecotmr itself computed from a recorded beta/se went out as though the +# source had provided it -- which tells a reader the opposite of the truth +# 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) + 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", { + 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 + # treated as not having supplied one: that is the safe direction, since + # claiming ES/SE were derived from a z is the assertion that misleads. + expect_false(is_in("EZ", .ezFields(.ezss(NULL)))) +}) + +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) + 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) + 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= columns rather than recomputing, so a writer +# can restrict what it publishes but can never invent a level. The error says +# what IS available instead of emitting a silently empty column. +# --------------------------------------------------------------------------- + +test_that("coverage = selects a subset of the levels the fit computed", { + data(qtlFineMappingExample, envir = environment()) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(qtlFineMappingExample, out, coverage = 0.95) + nms <- names(read.delim(out, check.names = FALSE)) + expect_true(is_in("CS95", nms)) + # The fit computed 70 and 50 as well; asking for 95 drops them. + expect_false(any(is_in(c("CS70", "CS50"), nms))) +}) + +test_that("coverage = names what the fit did compute, when asked for more", { + data(qtlFineMappingExample, envir = environment()) + out <- withr::local_tempfile(fileext = ".bed") + expect_error( + exportToBed(qtlFineMappingExample, out, coverage = c(0.95, 0.8)), + "asks for 80, which this fit did not compute.*Available: 95, 70, 50" + ) +}) + +test_that(".pubCsLevels reports the available set even when it is empty", { + # A view with no cs_ column at all: the message has to say "" + # rather than interpolate an empty vector away. + expect_error( + .pubCsLevels(tibble(pip = 0.5), coverage = 0.95), + "Available: " + ) + expect_equal(.pubCsLevels(tibble(cs_95 = "susie_1")), "95") +}) + +test_that("the fsusie schema refuses a result with no credible-set column", { + expect_error( + .fmbPrimaryCsLevel(tibble(pip = 0.5), NULL), + "carries no credible-set column, so there are no rows to key on" + ) +}) + +# --------------------------------------------------------------------------- +# EZ on the fine-mapping path, and AF from the LD panel +# --------------------------------------------------------------------------- + +test_that("a fine-mapping table publishes EZ when the source supplied z", { + # `.pubEz()` is the fine-mapping counterpart of the GwasSumStats rule: the + # z is published only where `marginal_z_supplied` says the source gave it, + # never where pecotmr derived it from beta/se. + tl <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + chrom = "chr1", + pos = c(100L, 200L), + A1 = c("G", "T"), + A2 = c("A", "C"), + pip = c(0.9, 0.1), + posterior_mean = c(0.2, -0.1), + posterior_sd = c(0.05, 0.05), + marginal_beta = c(0.3, -0.2), + marginal_se = c(0.1, 0.1), + marginal_z = c(5.5, -2.5), + marginal_z_supplied = c(TRUE, TRUE), + stringsAsFactors = FALSE + ) + row <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) + res <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "t", + method = "susie", + entry = list(row) + ) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(res, out, signalCutoff = 0) + tbl <- read.delim(out, check.names = FALSE) + expect_equal(tbl$EZ, c(5.5, -2.5)) + # Flip the flag and the column goes away entirely rather than publishing a + # z pecotmr computed itself. + tl$marginal_z_supplied <- c(FALSE, FALSE) + row2 <- fineMappingRow(tl$variant_id, susieFit = list(), topLoci = tl) + res2 <- QtlFineMappingResult( + studyName = "s", + context = "c", + trait = "t", + method = "susie", + entry = list(row2) + ) + exportToBed(res2, out, signalCutoff = 0) + expect_false(is_in("EZ", names(read.delim(out, check.names = FALSE)))) +}) + +test_that("a weights export takes AF from the collection's LD panel", { + # A TwasWeights element records only alleles and a weight, so the only + # frequency available is the panel's -- and AF is what a + # standardized-to-raw conversion would need, so its absence is worth + # seeing rather than faking. + data(twasWeightsExample, envir = environment()) + expect_null(ldSketch(twasWeightsExample)) + out <- withr::local_tempfile(fileext = ".bed") + suppressMessages(exportToBed(twasWeightsExample, out)) + expect_false(is_in("AF", names(read.delim(out, check.names = FALSE)))) +}) + +test_that("every weight row being fine-mapping-derived is an error", { + # Those weights are the fine-mapping posterior re-expressed, so there is + # nothing left to write once they are skipped. + data(twasWeightsExample, envir = environment()) + fm <- twasWeightsExample[ + is_in( + as.character(twasWeightsExample$method), + .TWB_FINE_MAPPING_METHODS + ) + ] + expect_gt(nrow(fm), 0L) + out <- withr::local_tempfile(fileext = ".bed") + expect_error( + suppressMessages(exportToBed(fm, out)), + "every row is fine-mapping-derived" + ) +}) + +test_that("the output path is left alone when no split flag is set", { + expect_equal( + .decorateOutputPath( + "out.vcf.bgz", + list(context = "brain"), + FALSE, + FALSE + ), + "out.vcf.bgz" + ) +}) + +test_that("an identity-less view keys on nothing; an empty range has no id", { + # A bare single-entry view carries none of the identity axes, so the join + # key degenerates to one empty string per row -- which is the right join + # for one entry. + expect_equal( + .pubIdentityKey(tibble(pip = c(0.1, 0.2)), .PUB_ROW_COLS), + c("", "") + ) + expect_equal(.pubRegionIds(GenomicRanges::GRanges()), character(0)) + expect_equal(.pubRegionIds(NULL), character(0)) +}) + +test_that("both formats skip fine-mapping-derived weight rows alike", { + # The BED path skipped them and the VCF path published them, so the two + # disagreed about what a weights file contains. The rule is the same in + # both: those weights are the fine-mapping posterior re-expressed, and the + # FineMappingResult says strictly more. + skip_if_not_installed("VariantAnnotation") + data(twasWeightsExample, envir = environment()) + derived <- is_in( + as.character(twasWeightsExample$method), + .TWB_FINE_MAPPING_METHODS + ) + expect_gt(sum(derived), 0L) + out <- withr::local_tempfile(fileext = ".vcf") + expect_message( + exportToVcf(twasWeightsExample, out), + "exportToVcf: skipping \\d+ fine-mapping-derived" + ) + header <- keep(readLines(out), str_starts, "#CHROM")[[1L]] + samples <- str_split(header, "\t")[[1L]][-seq_len(9L)] + expect_length(samples, sum(!derived)) + # None of the samples names a fine-mapping method. + expect_false(any(str_detect( + samples, + str_c("\\|", .TWB_FINE_MAPPING_METHODS, "$", collapse = "|") + ))) +}) + +test_that("a VCF of only fine-mapping-derived weights is refused", { + skip_if_not_installed("VariantAnnotation") + data(twasWeightsExample, envir = environment()) + fm <- twasWeightsExample[is_in( + as.character(twasWeightsExample$method), + .TWB_FINE_MAPPING_METHODS + )] + out <- withr::local_tempfile(fileext = ".vcf") + expect_error( + suppressMessages(exportToVcf(fm, out)), + "every selected row is fine-mapping-derived" + ) +}) + +test_that("a weights export reads AF off the collection's LD panel", { + # A TwasWeights element records only alleles and a weight, so the panel is + # the only place a frequency can come from. This panel carries no `af`, so + # the column stays absent rather than being faked. + data(ctwasWeightsExample, twasWeightsExample, envir = environment()) + panel <- ldSketch(ctwasWeightsExample) + expect_false(is.null(panel)) + lasso <- twasWeightsExample[ + as.character(twasWeightsExample$method) == "lasso" + ] + expect_equal(nrow(lasso), 1L) + withPanel <- TwasWeights( + studyName = as.character(lasso$study), + context = as.character(lasso$context), + trait = as.character(lasso$trait), + method = as.character(lasso$method), + entry = list(.twrRowParts(lasso, 1L)), + ldSketch = panel + ) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(withPanel, out) + expect_false(is_in("AF", names(read.delim(out, check.names = FALSE)))) +}) + +test_that("a sumstats collection with no Z publishes no EZ", { + skip_if_not_installed("VariantAnnotation") + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100L, 200L), width = 1L) + ) + gr <- S4Vectors::`mcols<-`( + gr, + value = S4Vectors::DataFrame( + SNP = c("chr1:100:A:G", "chr1:200:C:T"), + A1 = c("G", "T"), + A2 = c("A", "C"), + N = c(1000L, 1000L), + BETA = c(0.25, -0.12), + SE = c(0.1, 0.1) + ) + ) + ss <- GwasSumStats( + studyName = "s", + entry = list(gr), + genome = "hg38" + ) + out <- withr::local_tempfile(fileext = ".vcf") + exportToVcf(ss, out) + expect_false(any(str_detect(readLines(out), "ID=EZ,"))) +}) + +# --------------------------------------------------------------------------- +# A joint (matrix-weight) model, and AF from the LD panel +# --------------------------------------------------------------------------- + +# A multi-trait weight matrix on a panel that records allele frequency: the +# two shapes the single-trait fixtures never exercise. `mr_mash` because the +# matrix-weight fixture is a susie fit, which both exporters refuse as +# fine-mapping-derived -- a joint TWAS fit is the case that reaches the +# matrix paths at all. +# @noRd +.pbw_jointWeights <- function(nVariant = 6L) { + data(ctwasWeightsExample, envir = environment()) + panel <- ldSketch(ctwasWeightsExample) + vids <- .grVariantIds(SummarizedExperiment::rowRanges(panel)) + SummarizedExperiment::rowRanges(panel)$af <- seq( + 0.05, + 0.45, + length.out = length(vids) + ) + w <- matrix( + c(0.1, -0.2, 0.3, 0, 0.05, -0.4, 0.2, 0.1, -0.1, 0.3, 0, 0.15), + nrow = 6L, + dimnames = list(NULL, c("tA", "tB")) + ) + TwasWeights( + studyName = "S1", + context = "ctx", + trait = "tA", + method = "mr_mash", + entry = list(twasWeightsRow( + variantIds = vids[seq_len(nVariant)], + weights = w[seq_len(nVariant), , drop = FALSE] + )), + ldSketch = panel + ) +} + +test_that("a joint fit writes one BED row per (variant, trait)", { + tw <- .pbw_jointWeights() + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(tw, out) + bed <- read.delim(out, check.names = FALSE) + # Six variants x two weight columns, and the matrix column label -- not + # the row's own trait -- is what each block is published under. + expect_equal(nrow(bed), 12L) + expect_equal(sort(unique(bed$trait)), c("tA", "tB")) + expect_equal(bed$WGT[bed$trait == "tB"][[1L]], 0.2) +}) + +test_that("AF is published from the LD panel when it records one", { + tw <- .pbw_jointWeights() + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(tw, out) + bed <- read.delim(out, check.names = FALSE) + panel <- ldSketch(tw) + rr <- SummarizedExperiment::rowRanges(panel) + expected <- mcols(rr)$af[match(bed$ID, .grVariantIds(rr))] + expect_equal(bed$AF, expected) +}) + +test_that("a panel with no AF column publishes no AF at all", { + data(twasWeightsExample, envir = environment()) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(twasWeightsExample[5], out) + # An all-NA column is dropped rather than written as a column of ".", + # so the absence of a frequency is visible in the file's shape. + expect_false(is_in("AF", names(read.delim(out, check.names = FALSE)))) +}) + +test_that("a joint fit's VCF samples carry the weight-column label", { + skip_if_not_installed("VariantAnnotation") + tw <- .pbw_jointWeights() + out <- withr::local_tempfile(fileext = ".vcf") + exportToVcf(tw, out) + hdr <- readLines(out) + chrom <- hdr[str_starts(hdr, "#CHROM")] + # The label is appended to the row's identity, so two weight columns of + # one row stay two distinguishable samples. + expect_match(chrom, "S1\\|ctx\\|tA\\|mr_mash\\|tA") + expect_match(chrom, "S1\\|ctx\\|tA\\|mr_mash\\|tB") +}) + +test_that("a recorded data_source wins over the derived one", { + data(qtlFineMappingExample, envir = environment()) + x <- qtlFineMappingExample + # These rows record where they came from. The collection carries no LD + # panel, so the value the writer would DERIVE is "individual" -- and a + # published file must report what the rows recorded instead of + # re-deriving it from the object it happens to be held in. + recorded <- QtlFineMappingResult( + studyName = as.character(x$study), + context = as.character(x$context), + trait = as.character(x$trait), + method = as.character(x$method), + entry = map(seq_len(nrow(x)), .fmrRowParts, x = x), + dataSource = rep("sumstat", nrow(x)) + ) + expect_equal(.pubDataSource(recorded), "individual") + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(recorded, out) + bed <- read.delim(out, check.names = FALSE) + expect_equal(unique(bed$data_source), "sumstat") +}) + +test_that("columns= appends a hand-built row's own variant columns", { + # `twasWeightsRow()` writes exactly A1 / A2 / weight, which is the whole + # published source set -- so for a constructor-built collection there is + # nothing left for `columns` to add, as ?exportToBed says. A collection + # assembled by hand is the case the argument exists for: its variants + # carry fields pecotmr knows nothing about, and they travel into the file + # AFTER the published schema rather than displacing any of it. + vids <- sprintf("chr1:%d:A:G", 100L * (1:4)) + gr <- .variantIdsToGRanges(vids, "variantIds") + mcols(gr)$weight <- c(0.1, -0.2, 0.3, 0) + mcols(gr)$n_fold <- rep(5L, 4L) + mcols(gr)$qc_note <- c("ok", "ok", "flipped", "ok") + row <- methods::new( + "TwasWeightsRow", + variants = gr, + weights = c(0.1, -0.2, 0.3, 0), + weightStandardized = FALSE + ) + tw <- TwasWeights( + studyName = "S", + context = "c", + trait = "t", + method = "lasso", + entry = list(row) + ) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(tw, out, columns = "all") + bed <- read.delim(out, check.names = FALSE) + expect_equal(bed$qc_note, c("ok", "ok", "flipped", "ok")) + expect_equal(bed$n_fold, rep(5L, 4L)) + # The published columns still lead, and the weight is published as WGT + # rather than appearing a second time under its source name. + expect_equal(names(bed)[1:4], c("#chr", "start", "end", "ID")) + expect_false(is_in("weight", names(bed))) + # Naming one explicitly works the same way; naming a published one is an + # error rather than a duplicate column. + exportToBed(tw, out, columns = "qc_note") + expect_false(is_in("n_fold", names(read.delim(out, check.names = FALSE)))) + expect_error( + exportToBed(tw, out, columns = "weight"), + "already writes" + ) +}) + +test_that("a weight matrix with no columns publishes a header-only file", { + # A joint fit that retained no conditions leaves a 0-column weight + # matrix, so the row contributes no (variant, trait) block at all. The + # published file is then the schema with no rows -- the same shape an + # empty result takes everywhere else -- rather than a file with no header + # a reader could not parse. + gr <- .variantIdsToGRanges(sprintf("chr1:%d:A:G", 100L * (1:4)), "v") + w <- matrix(numeric(0), nrow = 4L, ncol = 0L) + mcols(gr)$weight <- w + tw <- TwasWeights( + studyName = "S", + context = "c", + trait = "t", + method = "lasso", + entry = list(methods::new( + "TwasWeightsRow", + variants = gr, + weights = w, + weightStandardized = FALSE + )) + ) + expect_length(.twbWeightLabels(mcols(tw[[1L]])$weight), 0L) + expect_null(.twbWeightsTable(tw, NULL, NULL)) + out <- withr::local_tempfile(fileext = ".bed") + exportToBed(tw, out) + lines <- readLines(out) + expect_length(lines, 1L) + expect_equal( + str_split_1(lines[[1L]], "\t")[1:4], + c( + "#chr", + "start", + "end", + "ID" + ) + ) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 5c41bc0d..23f4ec35 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -170,7 +170,11 @@ test_that(".tupleSelectRowGwasFmr: zero-row input errors", { stringsAsFactors = FALSE ) expect_error( - pecotmr:::.tupleSelectRowGwasFmr(empty, studyName = "g1", method = "susie"), + pecotmr:::.tupleSelectRowGwasFmr( + empty, + studyName = "g1", + method = "susie" + ), "GwasFineMappingResult has no rows" ) }) @@ -263,7 +267,11 @@ test_that(".tupleSelectRowGwasFmr: ambiguous multi-match (no region) lists candi stringsAsFactors = FALSE ) expect_error( - pecotmr:::.tupleSelectRowGwasFmr(multi, studyName = "g1", method = "susie"), + pecotmr:::.tupleSelectRowGwasFmr( + multi, + studyName = "g1", + method = "susie" + ), "pass `region` to disambiguate" ) }) @@ -335,7 +343,7 @@ test_that(".fmrRowsMatching: a vector selector matches any listed value", { # .fmrRowMetadata (stable 5-column identity frame) # =========================================================================== -test_that(".fmrRowMetadata: emits all five identity columns, NA-filling absent ones", { +test_that(".fmrRowMetadata: emits all eight identity columns, NA-filling absent ones", { qtl <- .ts_coll( study = c("s1", "s1"), context = c("c1", "c2"), @@ -346,7 +354,16 @@ test_that(".fmrRowMetadata: emits all five identity columns, NA-filling absent o m <- pecotmr:::.fmrRowMetadata(qtl) expect_equal( names(m), - c("study", "context", "trait", "blockId", "method") + c( + "study", + "context", + "trait", + "blockId", + "method", + "dataType", + "dataSource", + "standardized" + ) ) expect_equal(m$context, c("c1", "c2")) expect_true(all(is.na(m$blockId))) # QTL frame has no blockId @@ -376,7 +393,16 @@ test_that(".fmrRowMetadata: zero-row input yields a zero-row 5-column frame", { expect_equal(nrow(m), 0L) expect_equal( names(m), - c("study", "context", "trait", "blockId", "method") + c( + "study", + "context", + "trait", + "blockId", + "method", + "dataType", + "dataSource", + "standardized" + ) ) }) @@ -635,3 +661,92 @@ test_that(".twrRowResolveWeights drops rows whose weights are all NA", { test_that(".ssConcatChr answers character(0) for no pieces", { expect_identical(pecotmr:::.ssConcatChr(list()), character(0)) }) + +# ---- the stored analysis window --------------------------------------------- + +test_that("genomicRegion() is the analysis window, not the variant span", { + data(qtlFineMappingExample) + x <- qtlFineMappingExample + # Built without a window: fall back to the derived span, so the accessor + # never returns nothing where it used to return a range. + expect_s4_class(genomicRegion(x), "GRanges") + + want <- GenomicRanges::GRanges("chr22:1-50000000") + withWindow <- QtlFineMappingResult( + studyName = as.character(.tupleColumn(x, "study")), + context = as.character(.tupleColumn(x, "context")), + trait = as.character(.tupleColumn(x, "trait")), + method = as.character(.tupleColumn(x, "method")), + entry = list(.fmrRowParts(x, 1L)), + region = rep(want, nrow(x)) + ) + expect_identical( + as.character(genomicRegion(withWindow)), + rep(as.character(want), nrow(x)) + ) + # The window is WIDER than the variants that survived -- that gap is the + # whole reason it has to be stored rather than derived. + span <- unlist(range(withWindow), use.names = FALSE) + expect_gt( + GenomicRanges::start(span)[[1L]], + GenomicRanges::start(want)[[1L]] + ) + expect_lt(GenomicRanges::end(span)[[1L]], GenomicRanges::end(want)[[1L]]) +}) + +test_that("the stored window survives subsetting, the derived span does not", { + data(qtlFineMappingExample) + x <- qtlFineMappingExample + want <- GenomicRanges::GRanges("chr22:1-50000000") + obj <- QtlFineMappingResult( + studyName = as.character(.tupleColumn(x, "study")), + context = as.character(.tupleColumn(x, "context")), + trait = as.character(.tupleColumn(x, "trait")), + method = as.character(.tupleColumn(x, "method")), + entry = list(.fmrRowParts(x, 1L)), + region = rep(want, nrow(x)) + ) + # Provenance: a subset of a fit's variants was still produced by a fit + # over the original window, so this must NOT move. + expect_identical( + as.character(genomicRegion(obj[1L])), + as.character(want) + ) +}) + +test_that("a region column must be a GRanges with one range per row", { + data(qtlFineMappingExample) + x <- qtlFineMappingExample + build <- function(rg) { + QtlFineMappingResult( + studyName = as.character(.tupleColumn(x, "study")), + context = as.character(.tupleColumn(x, "context")), + trait = as.character(.tupleColumn(x, "trait")), + method = as.character(.tupleColumn(x, "method")), + entry = list(.fmrRowParts(x, 1L)), + region = rg + ) + } + expect_error(build("chr22:1-2"), "must be a GRanges") + expect_error( + build(GenomicRanges::GRanges(c("chr22:1-2", "chr22:3-4"))), + "same length as" + ) +}) + +test_that(".asAnalysisWindow normalizes strings, GRanges and multi-range input", { + expect_null(.asAnalysisWindow(NULL)) + expect_null(.asAnalysisWindow(GenomicRanges::GRanges())) + expect_identical( + as.character(.asAnalysisWindow("chr1:100-200")), + as.character(GenomicRanges::GRanges("chr1:100-200")) + ) + # A multi-range window collapses to the span it covered. + span <- .asAnalysisWindow(GenomicRanges::GRanges(c( + "chr1:100-200", + "chr1:500-900" + ))) + expect_length(span, 1L) + expect_identical(GenomicRanges::start(span)[[1L]], 100L) + expect_identical(GenomicRanges::end(span)[[1L]], 900L) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index ba6fe4dd..2f3a1dff 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -4536,3 +4536,95 @@ test_that(".ensembleAssertCv reports the fold count it actually saw", { CrossValidationParam(folds = 0) )) }) + +# --------------------------------------------------------------------------- +# The weight SCALE declaration +# +# `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. +# --------------------------------------------------------------------------- + +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, + crossValidationArgs = 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 + # its rows record TRUE on their own. + ss <- .tp_makeQtlSumStats() + expect_error( + twasWeightsPipeline(ss, methods = "lasso", weightStandardized = FALSE), + "unused argument" + ) + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockSumstatWeights(), + list(.package = "pecotmr") + ) + ) + res <- suppressMessages(suppressWarnings( + twasWeightsPipeline(ss, methods = "lasso", verbose = 0) + )) + expect_true(all(as.logical(S4Vectors::mcols(res)$standardized))) +}) + +test_that("the TWAS genotype scale also comes from the accessor", { + qd <- .tp_makeQtlDataset() + exec( + local_mocked_bindings, + !!!c( + list(extractBlockGenotypes = .tp_mockExtractor()), + .tp_mockIndividualWeights(), + list(.package = "pecotmr") + ) + ) + recorded <- function(...) { + res <- suppressMessages(suppressWarnings(twasWeightsPipeline( + qd, + methods = "lasso", + cisWindow = 1000L, + estimatePi = FALSE, + verbose = 0, + crossValidationArgs = CrossValidationParam(folds = 0), + residualizationArgs = ResidualizationParam(...) + ))) + unique(as.logical(S4Vectors::mcols(res)$standardized)) + } + expect_true(recorded()) + expect_false(recorded(scaleResiduals = FALSE)) +}) + +test_that("no TWAS pipeline takes a standardizeGenotypes argument", { + expect_false(is_in( + "standardizeGenotypes", + names(formals(pecotmr:::.twasPipelineQtlDataset)) + )) +}) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index d0f1e581..b587414d 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -201,9 +201,33 @@ test_that("parseRegion: handles X chromosome", { 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 'chr:start-end'") - expect_error(parseRegion("1:100:200"), "format must be 'chr:start-end'") + 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", { diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R deleted file mode 100644 index ceb8b70f..00000000 --- a/tests/testthat/test_vcfWriter.R +++ /dev/null @@ -1,747 +0,0 @@ -# Tests for writeSumStatsVcf (vcfWriter.R) - -# ============================================================================= -# Test data helpers -# ============================================================================= - -makeTestGenotypeHandle <- function() { - new( - "GenotypeHandle", - path = "/tmp/test.gds", - format = "gds", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) -} - -makeTestGwasSumStats <- function(n = 5) { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = seq(100, by = 100, length.out = n), width = 1) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = paste0("rs", seq_len(n)), - A1 = rep("A", n), - A2 = rep("T", n), - Z = seq(1.5, by = -0.5, length.out = n), - N = rep(1000L, n) - ) - GwasSumStats( - studyName = "test_trait", - entry = list(gr), - genome = "hg38", - ldSketch = makeTestGenotypeHandle() - ) -} - -makeTestFineMappingResult <- function(n = 5) { - beta <- seq(0.5, by = -0.1, length.out = n) - se <- rep(0.1, n) - zv <- seq(5.0, by = -1.0, length.out = n) - tl <- data.frame( - variant_id = paste0( - "chr1:", - seq(100, by = 100, length.out = n), - ":T:A" - ), - chrom = rep("1", n), - pos = as.integer(seq(100, by = 100, length.out = n)), - A1 = rep("A", n), - A2 = rep("T", n), - N = rep(1000, n), - MAF = rep(0.1, n), - marginal_beta = beta, - marginal_se = se, - marginal_z = zv, - marginal_p = 2 * pnorm(-abs(zv)), - pip = seq(0.9, by = -0.1, length.out = n), - posterior_mean = beta * 0.5, - posterior_sd = se * 0.5, - cs_95 = paste0("susie_", c(1L, 1L, 0L, 2L, 0L)[seq_len(n)]), - method = rep("susie", n), - stringsAsFactors = FALSE - ) - entry <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl - ) - GwasFineMappingResult( - studyName = "test_study", - method = "susie", - entry = list(entry) - ) -} - -# ============================================================================= -# GwasSumStats to VCF -# ============================================================================= - -test_that("writeSumStatsVcf 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 <- writeSumStatsVcf(ss, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -# ============================================================================= -# GwasSumStats to bgzipped VCF -# ============================================================================= - -test_that("writeSumStatsVcf 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 <- writeSumStatsVcf(ss, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -# ============================================================================= -# FineMappingResult to VCF -# ============================================================================= - -test_that("writeSumStatsVcf writes FineMappingResult to uncompressed VCF", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - - fm <- makeTestFineMappingResult(5) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - - result <- writeSumStatsVcf(fm, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -test_that("writeSumStatsVcf(FineMappingResult): emits PIP + CS posterior 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) - writeSumStatsVcf(fm, 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. - expect_true(any(grepl("ID=PIP,", ln, fixed = TRUE))) - expect_true(any(grepl("ID=CS95,", ln, fixed = TRUE))) - data1 <- ln[!grepl("^#", ln)][[1L]] - fmtKeys <- strsplit(strsplit(data1, "\t")[[1L]][[9L]], ":")[[1L]] - expect_true("PIP" %in% fmtKeys) - expect_true("CS95" %in% fmtKeys) - # cs_95 "susie_" -> integer CS index; fixture row 1 is in CS 1. - vals <- strsplit(strsplit(data1, "\t")[[1L]][[10L]], ":")[[1L]] - expect_equal(vals[[which(fmtKeys == "CS95")]], "1") -}) - -# ============================================================================= -# FineMappingResult to BCF -# ============================================================================= - -test_that("writeSumStatsVcf writes FineMappingResult to BCF", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - skip_if_not_installed("Rsamtools") - - # asBcf may be temporarily disabled in some Rsamtools versions - asbcf_works <- tryCatch( - { - tmp_stem <- tempfile(fileext = ".vcf") - tmp_bgz <- paste0(tmp_stem, ".bgz") - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = 100, width = 1, names = "chr1:100:A:G") - ) - hdr <- VariantAnnotation::VCFHeader( - header = IRanges::DataFrameList( - fileformat = S4Vectors::DataFrame( - Value = "VCFv4.2", - row.names = "fileformat" - ) - ), - sample = "probe" - ) - cd <- S4Vectors::DataFrame(Samples = "probe", row.names = "probe") - v <- VariantAnnotation::VCF( - rowRanges = gr, - colData = cd, - exptData = list(header = hdr) - ) - VariantAnnotation::ref(v) <- Biostrings::DNAStringSet("A") - VariantAnnotation::alt(v) <- Biostrings::DNAStringSetList(list("T")) - VariantAnnotation::fixed(v)$FILTER <- "PASS" - VariantAnnotation::writeVcf(v, tmp_stem, index = TRUE) - bcf_stem <- tempfile() - Rsamtools::asBcf( - tmp_bgz, - dictionary = "chr1", - destination = bcf_stem - ) - TRUE - }, - error = function(e) FALSE - ) - skip_if(!asbcf_works, "Rsamtools::asBcf is not functional in this build") - - fm <- makeTestFineMappingResult(5) - out <- tempfile(fileext = ".bcf") - on.exit(unlink(out), add = TRUE) - - result <- writeSumStatsVcf(fm, out) - expect_equal(result, out) - expect_true(file.exists(out)) - expect_gt(file.info(out)$size, 0) -}) - -# ============================================================================= -# Empty FineMappingResult errors -# ============================================================================= - -test_that("writeSumStatsVcf errors on empty FineMappingResult", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - - empty_tl <- data.frame( - variant_id = character(0), - chrom = character(0), - pos = integer(0), - A1 = character(0), - A2 = character(0), - N = numeric(0), - MAF = numeric(0), - marginal_beta = numeric(0), - marginal_se = numeric(0), - marginal_z = numeric(0), - marginal_p = numeric(0), - pip = numeric(0), - posterior_mean = numeric(0), - posterior_sd = numeric(0), - stringsAsFactors = FALSE - ) - entry <- fineMappingRow( - variantIds = character(0), - susieFit = list(), - topLoci = empty_tl - ) - fm_empty <- GwasFineMappingResult( - studyName = "test_study", - method = "susie", - entry = list(entry) - ) - - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - - expect_error(writeSumStatsVcf(fm_empty, out), "no variants to write") -}) - -# ============================================================================= -# splitByContext / splitByTrait — one file per tuple -# ============================================================================= - -.makeMultiTupleQtlFmr <- function() { - contexts <- c("brain", "blood") - traits <- c("ENSG_A", "ENSG_B") - entries <- map(seq_along(contexts), function(i) { - ids <- paste0("chr1:", 100 * (1:3), ":T:A") - tl <- data.frame( - variant_id = ids, - chrom = rep("1", 3), - pos = c(100L, 200L, 300L), - A1 = rep("A", 3), - A2 = rep("T", 3), - N = rep(1000, 3), - MAF = rep(0.1, 3), - marginal_beta = c(0.3, 0.1, -0.2) + i / 100, - marginal_se = rep(0.05, 3), - marginal_z = c(6.0, 2.0, -4.0), - marginal_p = c(1e-9, 0.045, 6e-5), - pip = c(0.9, 0.5, 0.7), - posterior_mean = rep(0.05, 3), - posterior_sd = rep(0.02, 3), - cs_95 = paste0("susie_", c(1L, 1L, 0L)), - stringsAsFactors = FALSE - ) - fineMappingRow(variantIds = ids, susieFit = list(), topLoci = tl) - }) - QtlFineMappingResult( - studyName = rep("study1", 2), - context = contexts, - trait = traits, - method = rep("susie", 2), - entry = entries - ) -} - -test_that("writeSumStatsVcf(FineMappingResult): splitByContext emits one VCF per context", { - 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 <- writeSumStatsVcf(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)) - } -}) - -test_that("writeSumStatsVcf(FineMappingResult): splitByTrait emits one VCF per trait", { - 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 <- writeSumStatsVcf(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("writeSumStatsVcf(FineMappingResult): splitByContext + splitByTrait combines 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 <- writeSumStatsVcf( - 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("writeSumStatsVcf(FineMappingResult): multi-row without split flags requires selectors", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fmr <- .makeMultiTupleQtlFmr() - out <- tempfile(fileext = ".vcf") - expect_error(writeSumStatsVcf(fmr, out), "2 matching rows") -}) - -# ============================================================================= -# GwasSumStats: multi-study selection, MAF/AF field, .gz rename -# ============================================================================= - -.makeTwoStudyGwasSumStats <- function(n = 3, withMaf = FALSE) { - mkGr <- function() { - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges( - start = seq(100, by = 100, length.out = n), - width = 1 - ) - ) - mc <- S4Vectors::DataFrame( - SNP = paste0("rs", seq_len(n)), - A1 = rep("A", n), - A2 = rep("T", n), - Z = seq(1.5, by = -0.5, length.out = n), - N = rep(1000L, n) - ) - if (withMaf) { - mc$MAF <- rep(0.2, n) - } - S4Vectors::mcols(gr) <- mc - gr - } - GwasSumStats( - studyName = c("studyA", "studyB"), - entry = list(mkGr(), mkGr()), - genome = "hg38", - ldSketch = makeTestGenotypeHandle() - ) -} - -test_that("writeSumStatsVcf(GwasSumStats): multi-study without `study` selector errors", { - skip_if_not_installed("VariantAnnotation") - ss2 <- .makeTwoStudyGwasSumStats() - out <- tempfile(fileext = ".vcf") - expect_error(writeSumStatsVcf(ss2, out), "2 studies") -}) - -test_that("writeSumStatsVcf(GwasSumStats): `study` selector writes 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 <- writeSumStatsVcf(ss2, out, studyName = "studyB") - expect_equal(res, out) - expect_true(file.exists(out)) -}) - -test_that("writeSumStatsVcf(GwasSumStats): emits the AF genotype field when MAF present", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - ss <- GwasSumStats( - studyName = "t", - entry = list(local({ - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = c(100, 200, 300, 400), width = 1) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = paste0("rs", 1:4), - A1 = rep("A", 4), - A2 = rep("T", 4), - Z = c(1.5, 1.0, 0.5, 0.0), - N = rep(1000L, 4), - MAF = rep(0.2, 4) - ) - gr - })), - genome = "hg38", - ldSketch = makeTestGenotypeHandle() - ) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - writeSumStatsVcf(ss, out) - expect_true(file.exists(out)) - # The AF FORMAT field is declared in the header when MAF is present. - expect_true(any(grepl("ID=AF", readLines(out)))) -}) - -test_that("writeSumStatsVcf(GwasSumStats): .vcf.gz output is renamed from writeVcf's .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 <- writeSumStatsVcf(ss, out) - expect_equal(res, out) - # 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))) -}) - -# ============================================================================= -# FineMappingResult: explicit selectors, no-match error, composite/empty tags -# ============================================================================= - -test_that("writeSumStatsVcf(FineMappingResult): explicit 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 <- writeSumStatsVcf( - fmr, - out, - studyName = "study1", - context = "brain", - trait = "ENSG_A", - method = "susie" - ) - expect_equal(res, out) - expect_true(file.exists(out)) -}) - -test_that("writeSumStatsVcf(FineMappingResult): no matching rows errors", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fmr <- .makeMultiTupleQtlFmr() - out <- tempfile(fileext = ".vcf") - expect_error( - writeSumStatsVcf(fmr, out, studyName = "does_not_exist"), - "no rows match" - ) -}) - -test_that("writeSumStatsVcf(FineMappingResult): splitByContext decorates composite .vcf.bgz paths", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fmr <- .makeMultiTupleQtlFmr() - baseOut <- tempfile(fileext = ".vcf.bgz") - stem <- tools::file_path_sans_ext(tools::file_path_sans_ext(baseOut)) - on.exit( - unlink( - list.files( - dirname(baseOut), - pattern = basename(stem), - full.names = TRUE - ), - force = TRUE - ), - add = TRUE - ) - paths <- writeSumStatsVcf(fmr, baseOut, splitByContext = TRUE) - expect_length(paths, 2L) - # Composite extension is preserved while the context tag is injected before it. - expect_true(all(grepl("\\.vcf\\.bgz$", paths))) - expect_true(any(grepl("\\.brain\\.vcf\\.bgz$", paths))) - expect_true(any(grepl("\\.blood\\.vcf\\.bgz$", paths))) -}) - -test_that("writeSumStatsVcf(FineMappingResult): splitByContext on a context-less result 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 - # empty and the original output path is used unchanged. - fm <- makeTestFineMappingResult(5) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - paths <- writeSumStatsVcf(fm, out, splitByContext = TRUE) - expect_length(paths, 1L) - expect_equal(paths[[1L]], out) - expect_true(file.exists(out)) -}) - -test_that("writeSumStatsVcf(FineMappingResult): emits AF from the topLoci `af` column", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - # The marginal view projects allele frequency to a column named `af`, so a - # topLoci carrying `af` must surface as the AF genotype field. - n <- 3 - tl <- data.frame( - variant_id = paste0("chr1:", c(100, 200, 300), ":T:A"), - chrom = rep("1", n), - pos = c(100L, 200L, 300L), - A1 = rep("A", n), - A2 = rep("T", n), - N = rep(1000, n), - af = c(0.1, 0.2, 0.3), - marginal_beta = c(0.3, -0.2, 0.1), - marginal_se = rep(0.05, n), - marginal_z = c(6.0, -4.0, 2.0), - marginal_p = c(1e-9, 6e-5, 0.045), - pip = c(0.9, 0.7, 0.5), - posterior_mean = rep(0.05, n), - posterior_sd = rep(0.02, n), - cs_95 = paste0("susie_", c(1L, 0L, 2L)), - stringsAsFactors = FALSE - ) - entry <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl - ) - fm <- GwasFineMappingResult( - studyName = "s", - method = "susie", - entry = list(entry) - ) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - writeSumStatsVcf(fm, out) - expect_true(file.exists(out)) - expect_true(any(grepl("ID=AF", readLines(out)))) -}) - -test_that("writeSumStatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit FORMAT fields", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - # A rich topLoci exercises every posterior FORMAT field: per-variant logBF (LBF), - # local false sign rate (LFSR), per-CS purity (PUR), and the wide fullFit - # columns (within_cs_pip / cs_logbf_ / cs_effect_). - n <- 3 - tl <- data.frame( - variant_id = paste0("chr1:", c(100, 200, 300), ":T:A"), - chrom = rep("1", n), - pos = c(100L, 200L, 300L), - A1 = rep("A", n), - A2 = rep("T", n), - N = rep(1000, n), - marginal_beta = c(0.3, -0.2, 0.1), - marginal_se = rep(0.05, n), - marginal_z = c(6, -4, 2), - marginal_p = c(1e-9, 6e-5, 0.045), - pip = c(0.9, 0.7, 0.5), - posterior_mean = rep(0.05, n), - posterior_sd = rep(0.02, n), - logBF = c(3.1, 1.2, 0.4), - lfsr = c(0.01, 0.2, 0.4), - cs_95 = paste0("susie_", c(1L, 0L, 2L)), - cs_95_purity = c(0.95, 0, 0.88), - within_cs_pip = c(0.6, 0, 0.5), - cs_logbf_susie_1 = c(2.2, NA, NA), - cs_effect_susie_1 = c(0.4, NA, NA), - stringsAsFactors = FALSE - ) - entry <- fineMappingRow( - variantIds = tl$variant_id, - susieFit = list(), - topLoci = tl - ) - fm <- GwasFineMappingResult( - studyName = "s", - method = "susie", - entry = list(entry) - ) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - writeSumStatsVcf(fm, out) - ln <- readLines(out) - for (id in c( - "ID=LBF", - "ID=LFSR", - "ID=PUR95", - "ID=WITHIN_CS_PIP", - "ID=CS_LOGBF_SUSIE_1", - "ID=CS_EFFECT_SUSIE_1" - )) { - expect_true(any(grepl(id, ln, fixed = TRUE)), info = id) - } -}) - -test_that("writeSumStatsVcf(FineMappingResult): falls back to marginal sumstats when no posterior", { - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Biostrings") - fm <- makeTestFineMappingResult(5) - # Simulate an entry whose posterior table is unavailable (empty topLoci) so - # the marginal univariate sumstats alone drive the VCF body (the else-if branch). - testthat::local_mocked_bindings( - topLoci = function(x, ...) GenomicRanges::GRanges(), - .package = "pecotmr" - ) - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - writeSumStatsVcf(fm, out) - expect_true(file.exists(out)) - expect_true(any(grepl("ID=ES", readLines(out), fixed = TRUE))) # marginal beta -> ES -}) - - -# =========================================================================== -# Output formats -# =========================================================================== - -test_that("plain and bgzipped VCF are written, the latter with an index", { - skip_if_not_installed("VariantAnnotation") - data(gwasSumStatsS4Example) - d <- withr::local_tempdir() - writeSumStatsVcf(gwasSumStatsS4Example, outputPath = file.path(d, "a.vcf")) - expect_true(file.exists(file.path(d, "a.vcf"))) - writeSumStatsVcf( - gwasSumStatsS4Example, - outputPath = 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. - expect_true(file.exists(file.path(d, "b.vcf.bgz.tbi"))) -}) - -test_that("BCF output explains itself when Rsamtools cannot convert", { - # Rsamtools >= 2.26 raises "asBcf() is temporarily disabled". Left bare - # that surfaces as an opaque failure from a documented output format, so - # it is translated into the cause plus the workaround. - skip_if_not_installed("VariantAnnotation") - skip_if_not_installed("Rsamtools") - data(gwasSumStatsS4Example) - d <- withr::local_tempdir() - canConvert <- !inherits( - tryCatch( - Rsamtools::asBcf("nonexistent", "x", "y"), - error = function(e) e - ), - "error" - ) - skip_if(canConvert, "Rsamtools::asBcf() works here; nothing to translate") - expect_error( - writeSumStatsVcf( - gwasSumStatsS4Example, - outputPath = file.path(d, "c.bcf") - ), - "BCF output needs a working Rsamtools::asBcf" - ) -}) - -test_that(".vcfResolveBody uses posterior rows when no marginals exist", { - local_mocked_bindings( - topLoci = function(entry, signalCutoff) { - # topLoci() returns ranges carrying the per-variant columns in - # mcols(); these ids are deliberately not coordinate-shaped, so - # the ranges are built directly rather than parsed from them. - gr <- GenomicRanges::GRanges( - "chr1", - IRanges::IRanges(start = c(1L, 2L), width = 1L) - ) - S4Vectors::`mcols<-`( - gr, - value = S4Vectors::DataFrame( - variant_id = c("v1", "v2"), - pip = c(0.9, 0.1) - ) - ) - }, - marginalEffects = function(entry) stop("none"), - .package = "pecotmr" - ) - out <- pecotmr:::.vcfResolveBody("e", "S1") - expect_true(out$hasPost) - expect_equal(nrow(out$base), 2L) - # No marginal table to align against, so there is nothing to merge in. - expect_null(out$m) -}) - -test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { - skip_if_not_installed("VariantAnnotation") - out <- tempfile(fileext = ".vcf") - on.exit(unlink(out), add = TRUE) - geno <- matrix(c(1.5, -0.5), ncol = 1L, dimnames = list(NULL, "S1")) - header <- S4Vectors::DataFrame( - Number = "1", - Type = "Float", - Description = "Z score", - row.names = "Z" - ) - pecotmr:::.writeVcfImpl( - chrom = c("1", "1"), - pos = c(100L, 200L), - ref = c("A", "C"), - alt = c("G", "T"), - snpIds = c("rs1", "rs2"), - geno = list(Z = geno), - genoHeader = header, - sampleName = "S1", - outputPath = out - ) - body <- readLines(out) - body <- body[!startsWith(body, "#")] - expect_true(all(startsWith(body, "chr1\t"))) -}) diff --git a/vignettes/finemapping-postprocessing.Rmd b/vignettes/finemapping-postprocessing.Rmd index b8ff2818..be86bfd9 100644 --- a/vignettes/finemapping-postprocessing.Rmd +++ b/vignettes/finemapping-postprocessing.Rmd @@ -54,11 +54,29 @@ head(as.data.frame(loci)[, c( "pip", "cs_95", "cs_95_purity", - "beta", - "se" + "posterior_effect", + "posterior_se" )], 4) ``` +`posterior_effect` is the posterior mean effect — the same quantity a TWAS +weight is, and literally what `susieWeights()` returns — and `posterior_se` +its standard error. They are deliberately *not* called `beta`/`se`: +[`marginalEffects()`](#) publishes the **marginal** single-variant estimate +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. +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 +from. The published `weight_standardized` column records it. + `cs_95` names the credible set the variant belongs to, or is `NA` when it belongs to none. The `cs_70` / `cs_50` columns give the same membership at looser coverage, so a variant can be in a 95% set but not a 50% one. @@ -266,20 +284,73 @@ object the other helpers expect. ## Writing results out -`writeSumStatsVcf()` serialises a fine-mapping result — or summary -statistics — to GWAS-VCF, the interchange format most external tools read: +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. ```{r vcf, eval=FALSE} -writeSumStatsVcf( +exportToVcf( qtlFineMappingExample, - file = "finemapping.vcf.gz", - genome = "hg38" + outputPath = "finemapping.vcf.gz", + context = "context_1" ) ``` It needs the `VariantAnnotation` package, which is a suggested dependency rather than a hard one. +`exportToBed()` 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") +# every remaining column the view carries, after the published schema +exportToBed(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", + schema = "fsusie", levels = "wavelet") +``` + +Both accept a `list` of results and fold it into one sorted, indexed output, +so a genome's worth of per-region RDSes needs no separate concatenate step. + +## Reading results back + +`readFineMappingResult()` is the inverse, and it is also the way into pecotmr +for a result produced somewhere else: it reads either format and rebuilds the +collection, keyed by whatever `(study, context, trait, method)` tuples the +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") +``` + +It requires almost nothing: coordinate-encoding variant ids and a `PIP`. +Every other column is optional, because each consumer needs a different few — +Mendelian randomization the marginal effect and its standard error, +colocalization the log Bayes factors — and a table converted from another tool +will carry some and not others. A consumer reached without what it needs names +the column that is missing rather than quietly producing nothing. + +Two arguments exist for files that were assembled by hand. `studyName`, +`context`, `trait` and `method` fill in identity columns the file does not +record (a value that *disagrees* with the file is an error, not an override), +and `weightStandardized` says which genotype scale a published `WGT` is on — +required when the file does not say, because the two scales differ by a +per-variant, allele-frequency-dependent factor and neither is recognisable on +its own. + +`readTwasWeights()` does the same for a weights file. Note that a fine-mapping +table reads as weights too: the posterior effect *is* the prediction weight, +which is why both schemas publish it as `WGT`. + ## Next steps - [Fine-mapping](fine-mapping.html) — producing the results this vignette diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index 4addaaeb..54fe5be3 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -355,10 +355,24 @@ key <- list( ) w <- do.call(weights, c(list(tw), key)) length(w) -do.call(weightStandardized, c(list(tw), key)) # standardized or original scale +do.call(weightStandardized, c(list(tw), key)) # TRUE from the pipeline 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()` returns a named numeric vector for univariate methods and a matrix for multivariate ones. The remaining payloads are keyed the same way: `variantIds()` for the aligned variant set, `cvResult()` for the @@ -367,6 +381,54 @@ the full fit object when the pipeline kept fits (`fitRetention != "none"`). `resolveWeights()` returns the weights and their variant IDs together, which 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 +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 +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") +``` + +Both export the **full-data fit only**, and refuse an object that has none — +`twasWeightsPipeline(fitFullData = FALSE)` produces rows holding nothing but +cross-validation results, and those cannot be published: they describe +held-out folds, and fold membership is sample-level information. For the same +reason neither exporter writes CV metrics. Those stay on the object: + +```{r tw-cv, eval=FALSE} +cv <- cvResult(tw, studyName = "s1", context = "brain", trait = "g1", + method = "susie") +cv$performance # per-method metric matrix: corr, rsq, adj_rsq, pval, RMSE, MAE +``` + +Fine-mapping-derived rows (`susie`, `susie_inf`, `susie_ash`, `mvsusie`, +`fsusie`) are skipped with a message by **both** exporters, because their +"weights" are the fine-mapping posterior re-expressed — export the +`FineMappingResult` instead, which carries the posterior, its standard error +and the credible sets. Selecting only such a method, as in +`method = "susie"`, is therefore an error rather than an empty file. + +`readTwasWeights()` reads either format back into a `TwasWeights`: + +```{r tw-read, eval=FALSE} +tw <- readTwasWeights("weights.bed.gz") +tw <- readTwasWeights("weights.bed.gz", region = "chr22:10e6-19e6") +``` + +A weight is all it requires, so a table converted from another tool reads with +nothing but variant ids and a `WGT` column — plus the identity axes the +collection is keyed by, which `studyName` / `context` / `trait` / `method` +supply when the file does not record them. `weightStandardized` is required +when the file does not say which genotype scale the weights are on: that is +not recoverable from the numbers, since converting between the two rescales +every variant by its own allele-frequency-dependent factor. + ## Next steps - Combine the learned weights with a GWAS via