diff --git a/NAMESPACE b/NAMESPACE index 73488ae1..a1ffad9a 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -209,6 +209,7 @@ export(filterInvalidSummaryStat) export(filterMixtureComponents) export(filterRelatedness) export(filterVariantsByLdReference) +export(fineMappingAnnotations) export(fineMappingMethods) export(fineMappingPipeline) export(fineMappingResult) @@ -377,6 +378,7 @@ export(testedAnnotations) export(topLoci) export(traitNames) export(traitPosition) +export(trimFineMappingResult) export(twasPredict) export(twasWeights) export(twasWeightsCv) @@ -697,7 +699,6 @@ importFrom(checkmate, ) importFrom(dplyr, across, - add_count, all_of, any_of, arrange, @@ -706,6 +707,7 @@ importFrom(dplyr, case_when, coalesce, count, + cumall, desc, distinct, everything, @@ -759,6 +761,7 @@ importFrom(purrr, map, map2, map2_dbl, + map2_lgl, map_chr, map_dbl, map_dfr, @@ -778,6 +781,7 @@ importFrom(purrr, importFrom(quadprog,solve.QP) importFrom(readr, col_character, + col_integer, cols, read_lines, read_table @@ -828,6 +832,7 @@ importFrom(stringr, str_c, str_detect, str_ends, + str_extract, str_flatten, str_length, str_match, @@ -837,6 +842,7 @@ importFrom(stringr, str_replace_all, str_split, str_split_1, + str_split_fixed, str_starts, str_sub, str_to_lower, @@ -870,6 +876,12 @@ importFrom(utils, combn, head ) -importFrom(vctrs,vec_duplicate_detect) +importFrom(vctrs, + vec_chop, + vec_duplicate_detect, + vec_group_id, + vec_match, + vec_unique_loc +) importFrom(vroom,vroom) useDynLib(pecotmr, .registration = TRUE) diff --git a/R/AllClasses.R b/R/AllClasses.R index f3162612..5149c223 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -910,12 +910,15 @@ setMethod( #' \code{mcols} names the entry each row used (\code{NA} for a fit derived #' from individual-level data). Used downstream to check that the rows a #' pipeline combines share an LD reference. -#' @section Narrowed rows: Each row records in its \code{fitVariants} column -#' the ids of the variants its fit was made with (none for a row without a -#' fit). A row narrowed since -- by \code{endoapply()} or \code{[[<-} -- -#' keeps its fit as it was, so every reader of the fit warns, with -#' condition class \code{pecotmrFitCoverage}, when a row holds fewer -#' variants than its fit describes. The readers are the accessors +#' @section Narrowed rows: A row is built from its fit, holding the fit's +#' variables in the fit's order, so its fit is read off it by position. A +#' row narrowed since -- by \code{endoapply()} or \code{[[<-} -- keeps its +#' fit as it was, and is found in the fit by the names the fit gives its +#' variables (a narrowed row whose fit names none, such as a trimmed fit, +#' cannot be read). Every reader of the fit warns, with condition class +#' \code{pecotmrFitCoverage}, when a row holds fewer variants than its fit +#' describes. A row replaced by one of the same length is read by +#' position. The readers are the accessors #' (\code{susieFit()}, \code{lbf()}, \code{cvResult()}, #' \code{credibleSetSummary()} and the fSuSiE views), #' \code{computeCsCorrelation()}, \code{susieResult()}, @@ -1024,8 +1027,8 @@ setMethod( ) `[[<-`( withCv, - "fitVariants", - value = IRanges::CharacterList(map(entries, .fmRowFitVariants)) + "derivedColumns", + value = IRanges::CharacterList(map(entries, .fmRowDerivedColumns)) ) } @@ -1033,12 +1036,15 @@ setMethod( # identity column and collection-level slot. # @noRd .fmrFromEntries <- function(x, entries) { - grl <- `mcols<-`( - .rtlBindElements(map(entries, variants)), - value = .withEntryPayload(mcols(x, use.names = FALSE), entries) + # .rtlRebuild() carries the names, seqinfo (the genome build) and every + # slot -- the rows keep their keys in mcols, so the references go across + # as is -- and only the payload columns are new. + rebuilt <- .rtlRebuild(x, map(entries, variants), seq_len(length(x))) + withPayload <- `mcols<-`( + rebuilt, + value = .withEntryPayload(mcols(rebuilt, use.names = FALSE), entries) ) - # The rows keep their keys in mcols, so the references go across as is. - new(class(x), grl, ldReference = x@ldReference) + S4Vectors::`metadata<-`(withPayload, value = S4Vectors::metadata(x)) } # TRUE when an entry shares at least one variant with `keepVariants`, matched @@ -1052,6 +1058,173 @@ setMethod( length(matched$idxA) > 0L } +# ---- Trimming a collection to what its role reads --------------------------- + +#' @title Trim A Fine-Mapping Collection To What Its Role Reads +#' @description Keep, of each row's fit, only what a fine-mapping collection +#' is read for in its \code{role}, so a genome-wide collection fits in +#' memory. Nothing is sampled or summarized ahead of time: a trimmed +#' collection gives the same enrichment estimates as the untrimmed one, and +#' can still be resampled. +#' +#' \describe{ +#' \item{\code{"outcome"}}{The side whose PIPs are scanned, as in +#' \code{\link{qtlEnrichmentPipeline}}'s \code{gwasFineMappingResult}: +#' each fit keeps its \code{pip} and its credible sets (\code{sets}, +#' \code{sets_secondary}).} +#' \item{\code{"annotation"}}{The side whose single effects are sampled, +#' as in \code{qtlFineMappingResult}: each fit also keeps \code{alpha} +#' and the prior variances \code{V} of its effects of positive prior +#' variance -- the only ones the enrichment samples -- with rows and +#' entries named by effect id (\code{"L"}). A fit with no such +#' effect keeps a zero-row \code{alpha}.} +#' } +#' +#' Each row's per-variant columns are cut to the identity columns, the +#' PIPs and the credible-set columns, and those two are stored only where +#' the trimmed fit cannot give them back. The posterior summaries, marginal +#' statistics and per-fit metadata columns go, so \code{\link{topLoci}} of a +#' trimmed collection reports PIPs and credible sets only. The +#' cross-validation results go as well, so a trimmed collection cannot feed +#' \code{\link{twasWeightsPipeline}}. Identity columns, names, the genome +#' build, LD references and \code{metadata()} are kept. Trimming a trimmed +#' collection changes nothing. +#' @param x A \code{\link{GwasFineMappingResult}} or +#' \code{\link{QtlFineMappingResult}}. +#' @param role \code{"outcome"} or \code{"annotation"}. \code{NULL} (default) +#' picks by class: \code{"outcome"} for a \code{GwasFineMappingResult}, +#' \code{"annotation"} for a \code{QtlFineMappingResult}. +#' @return \code{x}, trimmed. +#' @examples +#' data(qtlFineMappingExample) +#' trimmed <- trimFineMappingResult(qtlFineMappingExample) +#' names(susieFit(trimmed)) +#' c( +#' before = utils::object.size(qtlFineMappingExample), +#' after = utils::object.size(trimmed) +#' ) +#' @importFrom checkmate assertMultiClass +#' @importFrom rlang arg_match0 +#' @export +trimFineMappingResult <- function(x, role = NULL) { + assertMultiClass(x, c("GwasFineMappingResult", "QtlFineMappingResult")) + byClass <- if (methods::is(x, "GwasFineMappingResult")) { + "outcome" + } else { + "annotation" + } + chosen <- arg_match0( + role %||% byClass, + c("outcome", "annotation"), + arg_nm = "role" + ) + entries <- map(seq_len(nrow(x)), .trimRow, x = x, role = chosen) + .fmrFromEntries(x, entries) +} + +# Row i of `x`, trimmed for `role`: its fit trimmed, its cross-validation +# results dropped, and its table cut to the PIPs and credible-set columns, +# which the row builder stores only where the trimmed fit cannot give them +# back. Each variant id is held once, by the row's ranges and alleles: the +# trimmed fit's vectors go unnamed, read by position, except for a row +# narrowed since its fit, which is found in the fit by name, so its fit keeps +# the names of its variables (.partsFitIds()). +# @noRd +.trimRow <- function(i, x, role) { + parts <- .fmrRowParts(x, i) + gr <- variants(parts) + if (length(gr) == 0L) { + return(parts) + } + tl <- .fmrPartsTopLoci(parts) + csCols <- names(tl)[str_detect(names(tl), "^cs_[0-9]+(_purity)?$")] + fit <- susieFit(parts) + fitIds <- if (.rowHoldsFit(length(gr), .fitWidth(fit))) { + NULL + } else { + .partsFitIds(parts) + } + .fmRowBuild( + `mcols<-`( + GenomicRanges::granges(gr, use.mcols = FALSE), + value = mcols(gr, use.names = FALSE)[, c("A1", "A2"), drop = FALSE] + ), + .trimFit(fit, role, fitIds), + tl[intersect(c("variant_id", "pip", csCols), names(tl))], + NULL + ) +} + +# A fit cut to what `role` reads (see trimFineMappingResult()), its PIPs and +# effect columns named by `fitIds` (a narrowed row's) or unnamed. A fit that +# is not a list -- none at all -- is left as it is. +# @noRd +.trimFit <- function(fit, role, fitIds = NULL) { + if (!is.list(fit) || length(fit) == 0L) { + return(fit) + } + kept <- compact(list( + pip = .trimNamed(fit[["pip"]], fitIds), + sets = fit[["sets"]], + sets_secondary = .trimSecondarySets(fit[["sets_secondary"]]) + )) + effects <- if (role == "annotation") .trimEffects(fit, fitIds) else list() + `class<-`(c(effects, kept), class(fit)) +} + +# `pip` named by `fitIds`, or unnamed when there are none to name it by. +# @noRd +.trimNamed <- function(pip, fitIds) { + if (is.null(pip)) { + return(NULL) + } + `names<-`(pip, if (length(fitIds) == length(pip)) fitIds) +} + +# The credible sets of each other coverage, without the per-coverage copies +# of the PIPs and the rest that a fit's sets_secondary may carry: only the +# sets are read (.csSetsForCoverage()). +# @noRd +.trimSecondarySets <- function(sec) { + if (length(sec) == 0L) { + return(NULL) + } + map(sec, .trimSetsOnly) +} + +# @noRd +.trimSetsOnly <- function(secondary) { + list(sets = secondary$sets) +} + +# The alpha rows and prior variances of the fit's effects of positive prior +# variance, named by effect id, and alpha's columns by `fitIds` when given. +# An already trimmed fit's names are its ids. +# @noRd +.trimEffects <- function(fit, fitIds = NULL) { + priorVariance <- fit[["V"]] %||% fit[["prior_variance"]] + if (is.null(fit[["alpha"]]) || is.null(priorVariance)) { + return(list()) + } + alpha <- as.matrix(fit[["alpha"]]) + ids <- if (.namedByEffect(alpha)) { + rownames(alpha) + } else { + str_c("L", seq_len(nrow(alpha))) + } + keep <- which(as.numeric(priorVariance) > 0) + list( + alpha = `dimnames<-`( + alpha[keep, , drop = FALSE], + list( + ids[keep], + if (length(fitIds) == ncol(alpha)) fitIds + ) + ), + V = set_names(as.numeric(priorVariance)[keep], ids[keep]) + ) +} + # ============================================================================= # Variant reconciliation between two fine-mapping collections # ----------------------------------------------------------------------------- @@ -1434,12 +1607,10 @@ setMethod( } ) -# Before rows recorded the variants their fits were made with, a collection -# had no `fitVariants` column. A fine-mapping fit names its own variants, so -# each row's are read off it; a row whose fit names none (a -# cross-validation-only row, or an unnamed fit) records what it holds, and a -# row with no fit records none. The inherited update runs either way, for -# the updates every collection shares. +# Collections saved while rows recorded the variants their fits were made +# with carry a `fitVariants` column. A row's variants are its fit's +# variables, read by position, so the column is dropped. The inherited update +# runs either way, for the updates every collection shares. #' @rdname updateObject-methods #' @export setMethod( @@ -1449,46 +1620,19 @@ setMethod( if (isTRUE(verbose)) { message(str_c("updateObject(object = '", class(object)[[1L]], "')")) } - if (!is_in("fitVariants", .tupleColumnNames(object))) { - fv <- map(seq_along(object), .fmrBackfillFitVariants, x = object) - object <- `$<-`(object, "fitVariants", IRanges::CharacterList(fv)) + md <- mcols(object, use.names = FALSE) + current <- if (is_in("fitVariants", colnames(md))) { + `mcols<-`( + object, + value = md[, colnames(md) != "fitVariants", drop = FALSE] + ) + } else { + object } - methods::callNextMethod(object, ..., verbose = verbose) + methods::callNextMethod(current, ..., verbose = verbose) } ) -# @noRd -.fmrBackfillFitVariants <- function(i, x) { - md <- mcols(x, use.names = FALSE) - fit <- md$susieFit[[i]] - if (length(fit) == 0L && is.null(md$cvResult[[i]])) { - return(character(0)) - } - named <- .fitNamedVariants(fit) - if (length(named) > 0L) { - return(normalizeVariantId(named)) - } - .grVariantIds(x[[i]]) -} - -# The variant names a fine-mapping fit carries: its PIPs' names, else the -# columns of its effect matrices (SuSiE, mvSuSiE) or of csd_X (fSuSiE); none -# for an unnamed fit. A null_weight fit gives its effect matrices one more -# column, which susieR names "null"; that is no variant. -# @noRd -.fitNamedVariants <- function(fit) { - if (!is.list(fit)) { - return(character(0)) - } - named <- as.character( - names(fit[["pip"]]) %||% - colnames(fit[["alpha"]]) %||% - colnames(fit[["lbf_variable"]]) %||% - names(fit[["csd_X"]]) - ) - named[named != "null"] -} - #' @rdname traitPosition #' @examples #' data(qtlDatasetExample) diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 4b985caf..c59f1e57 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -202,7 +202,9 @@ GwasFineMappingResult <- function( method = as.character(method), susieFit = S4Vectors::SimpleList(map(entry, susieFit)), cvResult = S4Vectors::SimpleList(map(entry, cvResult)), - fitVariants = IRanges::CharacterList(map(entry, .fmRowFitVariants)) + derivedColumns = IRanges::CharacterList( + map(entry, .fmRowDerivedColumns) + ) ) |> .appendBlockIdCol(blockId %||% rep(NA_character_, n), n) |> .appendTraitPosCol(traitPos, n) |> diff --git a/R/H2Estimate.R b/R/H2Estimate.R index 770ec8f0..ba618074 100644 --- a/R/H2Estimate.R +++ b/R/H2Estimate.R @@ -27,8 +27,8 @@ NULL #' NULL if unstratified. Two shapes are possible, depending on which route #' produced the estimate: #' \describe{ -#' \item{partitioned}{tau-based enrichment of the baseline annotations -#' (\code{computeBaselineEnrichment}, \code{.gldscEnrichmentDf}), with +#' \item{partitioned}{enrichment of the user's baseline annotations +#' from their partitioned heritabilities \eqn{A'A\tau}, with #' columns \code{annotation}, \code{tau}, \code{tauSe}, #' \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, #' \code{propH2}, \code{propSnps}.} diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index 482f2a08..727ff837 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -25,9 +25,8 @@ NULL #' Required \code{mcols()} columns: the identity tuple \code{study}, #' \code{context}, \code{trait} and \code{method}, which is unique, and #' each row's stored fit \code{susieFit} and cross-validation result -#' \code{cvResult}. The constructor also records \code{fitVariants}, the -#' variants each fit was made with. There is no LD-block axis: a trait's fit -#' is one row wherever its window falls. +#' \code{cvResult}. There is no LD-block axis: a trait's fit is one row +#' wherever its window falls. #' #' Optional columns \code{jointStudies}, \code{jointContexts}, #' \code{jointTraits} appear when the collection contains rows produced by a @@ -352,7 +351,9 @@ QtlFineMappingResult <- function( method = as.character(method), susieFit = S4Vectors::SimpleList(map(payloads, susieFit)), cvResult = S4Vectors::SimpleList(map(payloads, cvResult)), - fitVariants = IRanges::CharacterList(map(payloads, .fmRowFitVariants)) + derivedColumns = IRanges::CharacterList( + map(payloads, .fmRowDerivedColumns) + ) ) withJoint <- .qfmrAppendJointCols( baseCols, diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index c9250442..3cdb1f97 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -186,8 +186,16 @@ setMethod("genomicRegion", "RangedTupleList", function(x) { if (length(object) == 0L) { return(TRUE) } - spans <- lengths(range(object)) - bad <- which(spans > 1L) + # Compared as integer (seqname, strand) codes against each element's first + # range: range() would paste a string key for every range of a + # genome-wide collection to find the same thing. + flat <- unlist(object, use.names = FALSE) + n <- lengths(object) + key <- as.integer(seqnames(flat)) * + 3L + + as.integer(BiocGenerics::strand(flat)) + firstKey <- rep(key[(cumsum(n) - n + 1L)[n > 0L]], n[n > 0L]) + bad <- unique(rep(seq_along(object), n)[key != firstKey]) if (length(bad) == 0L) { return(TRUE) } @@ -608,11 +616,24 @@ setMethod("trim", "RangedTupleList", function(x, use.names = TRUE, ...) { # per element made building the keys cost a millisecond a row. # @noRd .rtlFirstSpans <- function(x) { - spans <- range(x) - n <- lengths(spans) + # Each element sits on one (seqname, strand) (.rtlCheckSingleSpan()), so + # its span is its smallest start to its largest end there: taken from + # integer vectors, where range() would paste a key for every range. + n <- lengths(x) has <- n > 0L - flat <- unlist(spans, use.names = FALSE) - list(first = flat[(cumsum(n) - n + 1L)[has]], has = has) + flat <- unlist(x, use.names = FALSE) + first <- (cumsum(n) - n + 1L)[has] + # min()/max() of a list of starts/ends are taken per element, in C. + spans <- GenomicRanges::GRanges( + seqnames(flat)[first], + IRanges::IRanges( + unname(min(start(x)[has])), + unname(max(end(x)[has])) + ), + strand = BiocGenerics::strand(flat)[first], + seqinfo = GenomeInfoDb::seqinfo(flat) + ) + list(first = spans, has = has) } # The key of the first range of `g`, a span: callers pass range() of a @@ -691,9 +712,11 @@ setMethod("trim", "RangedTupleList", function(x, use.names = TRUE, ...) { #' both in one \code{qcInfo} record have it split between the two. #' Their genome build is in \code{seqinfo()}; ones saved with it in a #' \code{genome} slot have it moved there. -#' \item Fine-mapping results and TWAS weights record the variants each -#' row was fitted on in a \code{fitVariants} column; ones saved without -#' it have it filled in from their fits. +#' \item TWAS weights record the variants each row was fitted on in a +#' \code{fitVariants} column; ones saved without it have it filled in +#' from their fits. Fine-mapping results no longer record them (a row's +#' variants are its fit's variables); ones saved with the column have +#' it dropped. #' \item A \code{CtwasResult} holds one element per region; one saved as a #' table of whole runs is rebuilt. #' \item A \code{QtlDataset} no longer stores run settings (genotype @@ -1262,7 +1285,11 @@ flattenTupleRanges <- function(x) { ) abort(msg) } - gr <- .rtlGatherElements(x, seq_len(length(x))) + gr <- if (methods::is(x, "FineMappingResultBase")) { + .fmrGatherVariants(x, seq_len(length(x))) + } else { + .rtlGatherElements(x, seq_len(length(x))) + } md <- mcols(x, use.names = FALSE) if (is.null(md) || ncol(md) == 0L || length(gr) == 0L) { return(gr) @@ -1341,10 +1368,59 @@ nestTupleRanges <- function(flat, template) { abort(msg) } keys <- .rtlNestKeys(flat, template, .rtlTupleKeyCols(template)) - elements <- map(keys$wanted, .rtlPickByKey, flat = flat, have = keys$have) + picked <- map(keys$wanted, .rtlPickByKey, flat = flat, have = keys$have) + elements <- if (methods::is(template, "FineMappingResultBase")) { + .fmrDropRestoredColumns(picked, template) + } else { + picked + } .rtlRebuild(template, elements, seq_len(length(template))) } +# Re-nested fine-mapping elements without the columns flattening derived back +# (see flattenTupleRanges()): the pip, unless the template stored it, and the +# credible-set columns each row records as derived -- each only while the +# row's fit still gives exactly those values, so a column a verb changed is +# kept. +# @noRd +.fmrDropRestoredColumns <- function(elements, template) { + storedPip <- .rtlHasVariantColumn(template, "pip") + map2( + elements, + seq_along(elements), + .fmrDropRestoredAt, + template = template, + storedPip = storedPip + ) +} + +# @noRd +.fmrDropRestoredAt <- function(g, i, template, storedPip) { + parts <- .fmrRowParts(template, i) + recorded <- .fmRowDerivedColumns(parts) + if (length(g) == 0L) { + md <- mcols(g, use.names = FALSE) + labelCols <- .fmRowCsRecord(recorded)$labels + derived <- c( + if (storedPip) character(0) else "pip", + labelCols, + str_c(labelCols, "_purity") + ) + return(`mcols<-`( + g, + value = md[, setdiff(colnames(md), derived), drop = FALSE] + )) + } + fit <- susieFit(parts) + cols <- .fitColumnsFor(g, fit) + slim <- if (storedPip) g else .fmRowDropFitPip(g, fit, cols) + if (length(recorded) == 0L) { + return(slim) + } + cs <- .fmRowDropFitCs(slim, fit, cols) + if (identical(cs$derived, recorded)) cs$variants else slim +} + # Element and range keys for re-nesting. The identity tuple alone keys an # element unless several elements share it -- one tuple split across # chromosomes -- and then the one seqname each of those spans is added on both diff --git a/R/cpp11.R b/R/cpp11.R index 25978b9a..616bd9e2 100644 --- a/R/cpp11.R +++ b/R/cpp11.R @@ -36,8 +36,8 @@ prsCsFactorCpp <- function(a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thi .Call(`_pecotmr_prsCsFactorCpp`, a, b, phi, bhat, maf, n, factorR, nIter, nBurnin, thin, verbose, seed) } -qtlEnrichmentCpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { - .Call(`_pecotmr_qtlEnrichmentCpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) +qtlEnrichmentCpp <- function(rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) { + .Call(`_pecotmr_qtlEnrichmentCpp`, rGwasPip, rQtlSusieFit, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, seed) } sdprCpp <- function(bhatR, LD, n, perVariantSampleSize, array, a, c, M, a0k, b0k, iter, burn, thin, numThreads, optLlk, verbose, seed) { diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index 8824150d..9db22cca 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -28,10 +28,11 @@ NULL #' columns are the per-variant \code{topLoci} values. #' @slot susieFit The stored fine-mapping fit, or \code{NULL}. #' @slot cvResult Cross-validation payload, or \code{NULL}. -#' @slot fitVariants The ids of the variants the stored fit was made with, in -#' the fit's own order, recorded when the row is built; empty for a row with -#' no fit. A row narrowed to fewer variants keeps them, which is how reading -#' the fit can tell it describes more variants than the row now holds. +#' @slot derivedColumns The credible-set columns (\code{cs_} and +#' their \code{_purity} partners) the row does not store because its fit +#' reproduces them exactly, followed by \code{"method="}, the method +#' tag of their labels; every view derives them back. Empty when it stores +#' all it was given. #' @section Coercion: \code{as(x, "GRanges")} gives the row's variants with #' their per-variant \code{topLoci} columns: the element a collection #' stores for it. @@ -44,9 +45,13 @@ setClass( variants = "GRanges", susieFit = "ANY", cvResult = "ANY", - fitVariants = "character" + derivedColumns = "character" ), - prototype(susieFit = NULL, cvResult = NULL, fitVariants = character(0)) + prototype( + susieFit = NULL, + cvResult = NULL, + derivedColumns = character(0) + ) ) #' @importFrom checkmate makeAssertCollection assertList @@ -120,17 +125,369 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { if (nrow(tl) > 0L && is_in("variant_id", names(tl))) { .fmRowCheckIdOrder(vids, as.character(tl$variant_id)) } - gr <- .fmRowAttachPayload(bare, tl) - fitted <- length(susieFit) > 0L || !is.null(cvResult) + .fmRowBuild(bare, susieFit, tl, cvResult) +} + +# The row from its variant ranges `bare` and the checked table `tl`. The +# row's variants are its fit's variables, in the fit's order, unless it is a +# narrowed row trimFineMappingResult() rebuilds, whose fit names them. +# @noRd +.fmRowBuild <- function(bare, susieFit, tl, cvResult) { + # Placed once: both checks below read the fit at these columns. + cols <- .fitColumnsFor(bare, susieFit) + gr <- .fmRowDropFitPip(.fmRowAttachPayload(bare, tl), susieFit, cols) + cs <- .fmRowDropFitCs(gr, susieFit, cols) new( "FineMappingRow", - variants = gr, + variants = cs$variants, susieFit = susieFit, cvResult = cvResult, - fitVariants = if (fitted) .grVariantIds(bare) else character(0) + derivedColumns = cs$derived ) } +# The per-variant pip column is not stored when the fit reproduces it +# exactly: every reader restores it from the fit +# (.fmRowRestoredVariants()), and storing it twice doubles the PIPs a +# genome-wide collection holds. A pip the fit does not reproduce -- a row +# without a fit, or one whose table was edited -- is kept as it is, and so is +# one outside the place the readers restore it to (.fmRowPipSlot()), so a +# table comes back with its columns in the order it was given. +# @noRd +.fmRowDropFitPip <- function(gr, fit, cols = .fitColumnsFor(gr, fit)) { + md <- mcols(gr, use.names = FALSE) + if (length(gr) == 0L || !is_in("pip", colnames(md))) { + return(gr) + } + rest <- md[, colnames(md) != "pip", drop = FALSE] + if (.fmRowPipSlot(colnames(rest)) != match("pip", colnames(md)) - 1L) { + return(gr) + } + derived <- .fitPipFor(fit, cols) + if (is.null(derived) || !identical(derived, as.numeric(md$pip))) { + return(gr) + } + `mcols<-`(gr, value = rest) +} + +# The PIP the fit gives the variants at its columns `cols` +# (.fitColumnsFor()); NULL when the fit carries no PIP vector, or the +# variants could not be placed in it. +# @noRd +.fitPipFor <- function(fit, cols) { + pip <- if (is.list(fit)) fit[["pip"]] else NULL + if (!is.numeric(pip) || is.null(cols)) { + return(NULL) + } + as.numeric(pip)[cols] +} + +# How many of a row's variant columns `cn` precede its pip: those up to +# `marginal_p`, else up to `A2`, which is where the fine-mapping table puts +# it; a table with neither has it first. +# @noRd +.fmRowPipSlot <- function(cn) { + anchor <- intersect(c("marginal_p", "A2"), cn) + if (length(anchor) == 0L) { + return(0L) + } + match(anchor[[1L]], cn) +} + +# How many of a row's variant columns `cn` precede its credible-set block: +# those up to `logBF`, where buildTopLoci() puts it; in a table without one (a +# trimmed row, see trimFineMappingResult()), those up to `pip`, or up to +# where the pip goes when it is not stored either. +# @noRd +.fmRowCsSlot <- function(cn) { + anchor <- intersect(c("logBF", "pip"), cn) + if (length(anchor) == 0L) { + return(.fmRowPipSlot(cn)) + } + match(anchor[[1L]], cn) +} + +# A row's variants with every column the constructor dropped derived back +# from its fit: the recorded credible-set columns, then the pip. +# @noRd +.fmRowRestoredVariants <- function(row) { + .fmRowRestoreFitPip(.fmRowRestoreFitCs(variants(row), row), row) +} + +# `gr` with the pip column the constructor dropped restored from the fit of +# `row`: added after `marginal_p` (else after `A2`), where the fine-mapping +# table puts it, or filled where a collection joining rows with and without +# it left NA. A row whose fit gives no PIP is returned as it is. +# @noRd +.fmRowRestoreFitPip <- function(gr, row) { + md <- mcols(gr, use.names = FALSE) + has <- is_in("pip", colnames(md)) + if (length(gr) == 0L || (has && !anyNA(md$pip))) { + return(gr) + } + fit <- susieFit(row) + if (!is.numeric(if (is.list(fit)) fit[["pip"]])) { + return(gr) + } + derived <- .fitPipFor(fit, .fitColumnsPlaced(gr, fit)) + if (has) { + filled <- `[[<-`( + md, + "pip", + value = coalesce(as.numeric(md$pip), derived) + ) + return(`mcols<-`(gr, value = filled)) + } + .fmRowInsertColumns(gr, list(pip = derived), .fmRowPipSlot(colnames(md))) +} + +# The fit's columns of the variants `gr`, for restoring what the row does not +# store: an error when they cannot be placed in it (.fitColumnsFor()), since +# the values the row left to its fit would then be lost without a word. +# @noRd +.fitColumnsPlaced <- function(gr, fit) { + cols <- .fitColumnsFor(gr, fit) + if (is.null(cols)) { + .abortUnnamedNarrowedFit(length(gr), .fitWidth(fit)) + } + cols +} + +# `gr` with the columns `cols` inserted after its first `at` variant columns. +# @noRd +.fmRowInsertColumns <- function(gr, cols, at) { + md <- mcols(gr, use.names = FALSE) + `mcols<-`( + gr, + value = cbind( + md[, seq_len(at), drop = FALSE], + S4Vectors::DataFrame(cols, check.names = FALSE), + md[, setdiff(seq_len(ncol(md)), seq_len(at)), drop = FALSE] + ) + ) +} + +# The credible-set columns are not stored either when the fit reproduces +# them exactly, which is the common case: buildTopLoci() wrote them from the +# very credible sets the fit keeps (its `sets`, and `sets_secondary` for the +# other coverages), labelled with the method tag its labels carry. The whole +# block -- +# every coverage's cs_ label, then every cs__purity, highest coverage +# first, right after `logBF` as buildTopLoci() lays it out (see +# .fmRowCsSlot()) -- goes or stays +# together. It stays whenever the fit cannot give it back exactly: a fit +# without the credible sets of every coverage (an untrimmed fit with no +# recorded coverage, a fractional coverage), a table relabelled after the +# fact (adjustPips()), a row narrowed past its fit's variants, a table not +# laid out as buildTopLoci() lays it out. Returns the variants and the +# record of what went. +# @noRd +.fmRowDropFitCs <- function(gr, fit, cols = .fitColumnsFor(gr, fit)) { + kept <- list(variants = gr, derived = character(0)) + md <- mcols(gr, use.names = FALSE) + block <- .fmRowCsBlock(colnames(md)) + if (length(gr) == 0L || length(block) == 0L || !is.list(fit)) { + return(kept) + } + labelCols <- names(block$labels) + tag <- .fmRowCsLabelTag(md[, labelCols, drop = FALSE]) + derived <- .fitCsColumns(fit, labelCols, tag, cols, length(gr)) + if (is.null(derived)) { + return(kept) + } + stored <- as.list(md[, names(derived), drop = FALSE]) + if (!.fmRowSameCsColumns(stored, derived)) { + return(kept) + } + list( + variants = `mcols<-`( + gr, + value = md[, setdiff(colnames(md), names(derived)), drop = FALSE] + ), + derived = c(labelCols, str_c("method=", tag)) + ) +} + +# The method tag of a table's credible-set labels ("_"), read off the +# labels themselves; NULL unless they all carry the same one. +# @noRd +.fmRowCsLabelTag <- function(labels) { + values <- unique(list_c(map(as.list(labels), as.character))) + tags <- unique(str_remove(values[!is.na(values)], "_[0-9]+$")) + if (length(tags) != 1L || !nzchar(tags)) { + return(NULL) + } + tags +} + +# A row's record of derived credible-set columns, parsed: the cs_ label +# columns, highest coverage first, and the method tag their labels carry, +# which the record ends with as "method=". +# @noRd +.fmRowCsRecord <- function(record) { + tagAt <- str_detect(record, "^method=") + list( + labels = record[!tagAt], + tag = if (any(tagAt)) str_remove(record[tagAt][[1L]], "^method=") + ) +} + +# The credible-set block of a table with variant columns `cn`, when it is laid +# out as buildTopLoci() lays it out: the cs_ labels by decreasing coverage +# then their purities, contiguous, where .fmRowCsSlot() puts them. NULL +# otherwise. +# @noRd +.fmRowCsBlock <- function(cn) { + found <- cn[str_detect(cn, "^cs_[0-9]+$")] + if (length(found) == 0L) { + return(NULL) + } + coverage <- as.numeric(str_remove(found, "^cs_")) / 100 + labelCols <- found[order(coverage, decreasing = TRUE)] + expected <- c(labelCols, str_c(labelCols, "_purity")) + at <- .fmRowCsSlot(setdiff(cn, expected)) + if (!identical(cn[at + seq_along(expected)], expected)) { + return(NULL) + } + list(labels = set_names(sort(coverage, decreasing = TRUE), labelCols)) +} + +# Whether the stored credible-set columns are exactly the derived ones: +# labels compared as text, purities as numbers. +# @noRd +.fmRowSameCsColumns <- function(stored, derived) { + isLabel <- !str_detect(names(derived), "_purity$") + asStored <- c( + map(stored[isLabel], as.character), + map(stored[!isLabel], as.numeric) + ) + identical(asStored[names(derived)], derived) +} + +# The credible-set columns `labelCols` (cs_, highest coverage first) and +# their purities, as buildTopLoci() derives them from the fit's credible sets +# at each coverage, for the variants at the fit's columns `col` +# (.fitColumnsFor()) of a row of `n` variants. NULL when the fit cannot give +# them: no method tag, a coverage it kept no credible sets for, or a variant +# it was not made with or could not be placed in it. +# @noRd +.fitCsColumns <- function(fit, labelCols, tag, col, n) { + if (is.null(tag) || is.null(col) || anyNA(col)) { + return(NULL) + } + perCoverage <- map( + as.numeric(str_remove(labelCols, "^cs_")) / 100, + .fitCsAtCoverage, + fit = fit, + nV = coalesce(.fitWidth(fit), n) + ) + if (any(map_lgl(perCoverage, is.null))) { + return(NULL) + } + c( + set_names( + map(perCoverage, .fitCsLabelsAt, col = col, tag = tag), + labelCols + ), + set_names( + map(perCoverage, .fitCsPurityAt, col = col), + str_c(labelCols, "_purity") + ) + ) +} + +# One coverage's credible-set labels (.fitCsAtCoverage()) for the variants at +# the fit's columns `col`. +# @noRd +.fitCsLabelsAt <- function(perCoverage, col, tag) { + .btlCsLabel(perCoverage$effect[col], tag) +} + +# One coverage's credible-set purities for the variants at `col`. +# @noRd +.fitCsPurityAt <- function(perCoverage, col) { + perCoverage$purity[col] +} + +# One coverage's per-variable effect index and purity, as .btlCsMembership() +# computes them, from the credible sets the fit keeps for that coverage; NULL +# when it keeps none. +# @noRd +.fitCsAtCoverage <- function(coverage, fit, nV) { + sets <- .csSetsForCoverage(fit, coverage) + if (is.null(sets)) { + return(NULL) + } + tables <- list(list(sets = sets)) + position <- .fmCsIdxAtCoverage(coverage, coverage, tables, nV, quiet = TRUE) + list( + effect = .fmEffectIdxAtCoverage(coverage, position, coverage, tables), + purity = .fmPurityAtCoverage(coverage, position, coverage, tables) + ) +} + +# `gr` with the credible-set columns `row` records as derived restored from +# its fit: inserted where .fmRowCsSlot() puts them where they are absent +# (before the pip is restored, so that slot is the one they were dropped +# from), filled where a +# collection joining rows with and without them left them NA. +# @noRd +.fmRowRestoreFitCs <- function(gr, row) { + record <- .fmRowCsRecord(.fmRowDerivedColumns(row)) + md <- mcols(gr, use.names = FALSE) + if (length(record$labels) == 0L || length(gr) == 0L) { + return(gr) + } + wanted <- c(record$labels, str_c(record$labels, "_purity")) + if (all(map_lgl(wanted, .fmRowColumnFilled, md = md))) { + return(gr) + } + fit <- susieFit(row) + derived <- .fitCsColumns( + fit, + record$labels, + record$tag, + .fitColumnsPlaced(gr, fit), + length(gr) + ) + if (is.null(derived)) { + return(gr) + } + present <- intersect(names(derived), colnames(md)) + if (length(present) == 0L) { + return(.fmRowInsertColumns(gr, derived, .fmRowCsSlot(colnames(md)))) + } + filled <- reduce(present, .fmRowFillColumn, derived = derived, .init = md) + `mcols<-`(gr, value = filled) +} + +# `md` with its column `nm` taken from `derived` when it is all NA, as a +# collection joining rows with and without it leaves it. +# @noRd +.fmRowFillColumn <- function(md, nm, derived) { + if (!all(is.na(md[[nm]]))) { + return(md) + } + `[[<-`(md, nm, value = derived[[nm]]) +} + +# Whether `md` has column `nm` with a value somewhere: a column absent, or +# all NA where a collection joined rows with and without it, is restored. +# @noRd +.fmRowColumnFilled <- function(nm, md) { + is_in(nm, colnames(md)) && !all(is.na(md[[nm]])) +} + +# The credible-set columns a row records as derived. A row saved before rows +# recorded them has no such slot, and derives none. +# @noRd +.fmRowDerivedColumns <- function(x) { + if (!methods::.hasSlot(x, "derivedColumns")) { + return(character(0)) + } + x@derivedColumns +} + # The row a cross-validation-only fit leaves (CrossValidationParam(fitFullData = # FALSE)): no variants, no fit, no top loci -- only the cross-validation result # attached afterwards. The writers refuse such rows (.fmbIncompleteRows()), and @@ -522,10 +879,20 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # matrix. .csEffectLogBf <- function(fit, Lidx) { lbf <- fit$lbf_variable - if (is.null(lbf) || !is.matrix(lbf) || is.na(Lidx) || Lidx > nrow(lbf)) { + if (is.null(lbf) || !is.matrix(lbf) || is.na(Lidx)) { return(NA_real_) } - lv <- keep(as.numeric(lbf[Lidx, ]), is.finite) + row <- if (.namedByEffect(lbf)) { + match(str_c("L", Lidx), rownames(lbf)) + } else if (Lidx <= nrow(lbf)) { + Lidx + } else { + NA_integer_ + } + if (is.na(row)) { + return(NA_real_) + } + lv <- keep(as.numeric(lbf[row, ]), is.finite) if (length(lv) == 0L) { return(NA_real_) } @@ -543,13 +910,13 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # stored fit. The credible-set index in the `cs` label doubles as the effect (L) # index for susie-family fits (unfiltered CS are ordered by effect). # @noRd -.csSummaryFit <- function(tl, fit, coverage) { +.csSummaryFit <- function(tl, fit, coverage, fitIds = colnames(fit$alpha)) { csCol <- str_c("cs_", coverage * 100) purCol <- str_c(csCol, "_purity") if (is.null(tl) || nrow(tl) == 0L) { return(.emptyCsSummary()) } - specs <- .csSummarySpecs(tl, fit, coverage, csCol) + specs <- .csSummarySpecs(tl, fit, coverage, csCol, fitIds) if (length(specs) == 0L) { return(.emptyCsSummary()) } @@ -575,23 +942,24 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # membership. Falls back to enumerating the per-variant cs_ column (the # labelled members only) for a minimal or hand-built fit with no sets. # @noRd -.csSummarySpecs <- function(tl, fit, coverage, csCol) { +.csSummarySpecs <- function(tl, fit, coverage, csCol, fitIds) { setsObj <- .csSetsForCoverage(fit, coverage) hasSets <- !is.null(setsObj) && !is.null(setsObj$cs) && length(setsObj$cs) > 0L if (hasSets) { - return(.csSpecsFromFit(setsObj, fit, tl, csCol)) + return(.csSpecsFromFit(setsObj, fit, tl, csCol, fitIds)) } .csSpecsFromColumn(tl, csCol) } # Complete per-CS specs from the fit's credible sets. Member POSITIONS map to -# variant ids through the alpha column names; the effect index comes from the -# sets$cs "L" names. +# variant ids through `fitIds`, the variables the fit was made with in its +# order (a trimmed fit's vectors carry no names); the effect index comes from +# the sets$cs "L" names. # @noRd -.csSpecsFromFit <- function(setsObj, fit, tl, csCol) { - vn <- colnames(fit$alpha) +.csSpecsFromFit <- function(setsObj, fit, tl, csCol, fitIds) { + vn <- fitIds eff <- .fmEffectIndices(setsObj$cs) tag <- .csMethodTag(tl, fit, csCol) map( @@ -684,7 +1052,8 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # mean-purity, plus the resolved column names. # @noRd .csSummaryContext <- function(tl, fit, coverage, csCol, purCol) { - Vvec <- if (!is.null(fit$V)) as.numeric(fit$V) else NULL + # Names kept: a trimmed fit's V is named by effect id (.csEffectV()). + Vvec <- if (!is.null(fit$V)) set_names(as.numeric(fit$V), names(fit$V)) sp <- fit$sets$purity mc <- if (is.null(sp)) { character(0) @@ -765,11 +1134,22 @@ FineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { # V: the effect's prior variance (NA when out of range / unavailable). # @noRd .csEffectV <- function(Vvec, Lidx) { - if (!is.null(Vvec) && !is.na(Lidx) && Lidx <= length(Vvec)) { - Vvec[Lidx] - } else { - NA_real_ + if (is.null(Vvec) || is.na(Lidx)) { + return(NA_real_) + } + # A trimmed fit keeps only its effects of positive prior variance, named + # by effect id, so V[k] would be some other effect's; read it by name. + if (.namedByEffect(Vvec)) { + return(unname(as.numeric(Vvec[str_c("L", Lidx)]))) } + if (Lidx <= length(Vvec)) Vvec[Lidx] else NA_real_ +} + +# TRUE when a per-effect vector or matrix rows carry "L" effect ids. +# @noRd +.namedByEffect <- function(x) { + nm <- if (is.matrix(x)) rownames(x) else names(x) + length(nm) > 0L && all(str_detect(nm, "^L[0-9]+$")) } # cs_log10bf: strongest member logBF (NA when the column is absent). @@ -1648,7 +2028,7 @@ setMethod("adjustPips", "FineMappingRow", function(x, keepVariants) { length(fitted) ) newTopLoci <- .adjustPipsRebuildTopLoci( - .fmeTopLociFromElement(variants(x)), + .fmrPartsTopLoci(x), fit, common ) @@ -1680,9 +2060,6 @@ setMethod("susieFit", "FineMappingRow", function(x) x@susieFit) #' @export setMethod("cvResult", "FineMappingRow", function(x) x@cvResult) -# @noRd -.fmRowFitVariants <- function(x) x@fitVariants - #' @rdname show-methods #' @export setMethod("show", "FineMappingRow", function(object) { @@ -1718,4 +2095,6 @@ setMethod("variants", "FineMappingRow", function(x) x@variants) #' @aliases coerce,FineMappingRow,GRanges-method #' @usage NULL #' @exportMethod coerce -setAs("FineMappingRow", "GRanges", function(from) variants(from)) +setAs("FineMappingRow", "GRanges", function(from) { + .fmRowRestoredVariants(from) +}) diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 784930ca..4c0d836c 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -1394,14 +1394,17 @@ setMethod( } # Per-variant CS index at coverage `targetCov` (0 = not in any CS; on overlap -# the smallest cs_idx wins). +# the smallest cs_idx wins). A variant in several sets warns unless `quiet`, +# which re-deriving a stored table's columns sets: buildTopLoci() warned when +# it first wrote them. # @noRd .fmCsIdxAtCoverage <- function( targetCov, coverageValues, csTables, nV, - variantNames = NULL + variantNames = NULL, + quiet = FALSE ) { empty <- integer(nV) hit <- which(abs(coverageValues - targetCov) < 1e-12) @@ -1433,8 +1436,10 @@ setMethod( winnerAt <- variantOf[firstPerVariant] out <- .fmScatter(empty, winnerAt, winners) bestSize <- .fmScatter(rep(Inf, nV), winnerAt, setSizes[winners]) - memb <- split(csOf, factor(variantOf, levels = seq_len(nV))) - .fmWarnMultiCs(memb, out, bestSize, sets, variantNames) + if (!quiet) { + memb <- split(csOf, factor(variantOf, levels = seq_len(nV))) + .fmWarnMultiCs(memb, out, bestSize, sets, variantNames) + } out } @@ -1527,7 +1532,7 @@ setMethod( .fmPurityAtCoverage <- function(targetCov, idxVec, coverageValues, csTables) { h <- which(abs(coverageValues - targetCov) < 1e-12) pv <- if (length(h) > 0L) .csPurityVec(csTables[[h[1L]]]) else numeric() - map_dbl(idxVec, .csPurityAt, pv = pv) + .csPurityAt(idxVec, pv) } #' Build the unified top-loci table for one fit and one method @@ -5213,14 +5218,16 @@ extractTopPipInfo <- function(fmRow, sumstats) { ) } -# Purity value for the i-th index (0 out of range / NA). +# Purity value for each index `i` (0 out of range / NA), vectorised: it runs +# once per variant of every fit. # @noRd .csPurityAt <- function(i, pv) { - if (i <= 0L || i > length(pv)) { - return(0) - } - v <- pv[i] - if (is.na(v)) 0 else as.numeric(v) + inRange <- i > 0L & i <= length(pv) + replace( + numeric(length(i)), + inRange, + coalesce(as.numeric(pv[i[inRange]]), 0) + ) } # Max of the finite entries of x (NA when none). diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 53606e51..1f0253b1 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -1189,15 +1189,85 @@ resolvePlink2Paths <- function(prefix) { list(pgen = pgen, pvar = pvar, psam = psam) } -#' Read .pvar or .pvar.zst into a data.frame via pgenlibr. +#' Read .pvar or .pvar.zst into a data.frame. #' -#' Uses pgenlibr::NewPvar() to parse the file (handles both plain .pvar and -#' zstd-compressed .pvar.zst natively, no external CLI required). +#' A plain-text .pvar with a #CHROM header -- what PLINK2 writes -- is read as +#' one tab-separated table. Anything else (a zstd-compressed .pvar.zst, a +#' header-less .bim-style .pvar) is read through pgenlibr::NewPvar(), which +#' reads every format PLINK2 does but one variant per call: about 40 +#' microseconds a variant, eight minutes for a 12-million-variant panel. #' #' @param pvarPath Path to .pvar or .pvar.zst file. #' @return data.frame with columns: chrom, id, pos, A2 (REF), A1 (ALT). #' @noRd readPvar <- function(pvarPath) { + .readPvarTable(pvarPath) %||% .readPvarByVariant(pvarPath) +} + +# A plain-text .pvar read as a table, as pgenlibr reads it: the first ALT +# allele of a multi-allelic variant is A1. NULL for a file this cannot read +# (compressed, or with no #CHROM header naming the five columns). +# @noRd +#' @importFrom vroom vroom +#' @importFrom readr cols col_character col_integer +.readPvarTable <- function(pvarPath) { + if (str_detect(pvarPath, "\\.zst$")) { + return(NULL) + } + header <- .pvarHeader(pvarPath) + required <- c("CHROM", "POS", "ID", "REF", "ALT") + if (is.null(header) || !all(is_in(required, header$columns))) { + return(NULL) + } + tbl <- vroom( + pvarPath, + delim = "\t", + skip = header$lines, + col_names = header$columns, + col_select = all_of(required), + col_types = cols(.default = col_character(), POS = col_integer()), + na = character(), + quote = "", + comment = "", + progress = FALSE + ) + tibble( + chrom = tbl$CHROM, + id = tbl$ID, + pos = tbl$POS, + A2 = tbl$REF, + A1 = str_remove(tbl$ALT, ",.*$") + ) +} + +# The .pvar's column names, from its #CHROM header line, and how many lines +# (## meta lines and the header) precede the variants; NULL without one. Read +# in windows of growing size: a header of thousands of ## lines (a VCF's +# contigs) costs a few reads, and a short one reads little. +#' @importFrom readr read_lines +#' @importFrom dplyr cumall +#' @noRd +.pvarHeader <- function(pvarPath, window = 1024L) { + top <- read_lines(pvarPath, n_max = window, progress = FALSE) + # The meta lines: the run of "#" lines the file starts with. + meta <- cumall(str_starts(top, "#")) + header <- which(meta & str_starts(top, "#CHROM")) + if (length(header) > 0L) { + line <- top[[header[[1L]]]] + return(list( + columns = str_split_1(str_remove(line, "^#"), "\t"), + lines = header[[1L]] + )) + } + if (!all(meta) || length(top) < window) { + return(NULL) + } + .pvarHeader(pvarPath, window * 8L) +} + +# Any .pvar pgenlibr reads, a variant at a time. +# @noRd +.readPvarByVariant <- function(pvarPath) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { abort("Package 'pgenlibr' is required.") } diff --git a/R/h2Annotations.R b/R/h2Annotations.R index b42afed4..73f7afc1 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -199,3 +199,241 @@ setMethod( .bwMeanScore <- function(x) { if (length(x) > 0) mean(x) else 0 } + +# ============================================================================= +# Annotations from fine-mapping results +# ============================================================================= + +#' @title Annotations From Fine-Mapping Results +#' @description Turn fine-mapping results -- typically molecular QTLs -- into +#' per-variant annotations over an LD reference's variants, for +#' \code{\link{estimateH2}} to test for heritability enrichment. Each +#' (\code{study}, \code{context}, \code{method}) unit of \code{x} pools its +#' traits (e.g. genes) into one column per requested type: +#' \describe{ +#' \item{\code{"maxCpp"}}{A variant's largest PIP over the unit's traits +#' (continuous; Hormozdiari et al. 2018).} +#' \item{\code{"sumPip"}}{The sum of its PIPs over the traits: the +#' expected number of the unit's causal effects it carries +#' (continuous).} +#' \item{\code{"credibleSet"}}{1 when it sits in a credible set of any +#' trait at \code{coverage} (and \code{minPurity}), else 0.} +#' \item{\code{"highPip"}}{1 when its largest PIP is at least +#' \code{pipThreshold}, else 0.} +#' } +#' +#' Variants are matched to the reference allele-aware (id format, ref/alt +#' swap, strand) by their coordinates and alleles, so a reference naming +#' its variants by rsID matches too; a fine-mapped variant the reference +#' lacks contributes nothing, and a reference variant no trait fine-mapped +#' takes 0. A column that comes out all zero -- a unit none of whose +#' variants are in the reference, or none of whose PIPs reach +#' \code{pipThreshold} -- is dropped, with a warning. +#' +#' The rows follow the reference's variants in its order, as +#' \code{estimateH2} requires. +#' @param x A \code{\link{QtlFineMappingResult}} or +#' \code{\link{GwasFineMappingResult}}. +#' @param ldRef The \code{\linkS4class{LdStatistic}} the annotations will be +#' used with. +#' @param types Which annotation types to build; see above. Default all four. +#' @param coverage Credible-set coverage for \code{"credibleSet"}. Default +#' \code{0.95}. +#' @param minPurity Minimum credible-set purity for \code{"credibleSet"}; +#' \code{NULL} (default) applies none. +#' @param pipThreshold PIP cutoff for \code{"highPip"}. Default \code{0.5}. +#' @param tier The tier the columns take: \code{"candidate"} (default), so +#' \code{estimateH2} score-tests each for enrichment over the baseline, or +#' \code{"baseline"}, to fit them jointly with it. +#' @return An \code{\linkS4class{AnnotationMatrix}} with one row per variant of +#' \code{ldRef}. Columns are named +#' \code{"|||"}, omitting an axis \code{x} +#' does not have. +#' @examples +#' data(qtlFineMappingExample) +#' fm <- topLoci(qtlFineMappingExample, signalCutoff = 0) +#' ref <- LdScore( +#' ldBlocks = GenomicRanges::GRanges( +#' "chr22", +#' IRanges::IRanges(min(GenomicRanges::start(fm)), +#' max(GenomicRanges::start(fm))) +#' ), +#' snpInfo = data.frame( +#' SNP = S4Vectors::mcols(fm)$variant_id, +#' CHR = "chr22", +#' BP = GenomicRanges::start(fm), +#' A1 = S4Vectors::mcols(fm)$A1, +#' A2 = S4Vectors::mcols(fm)$A2 +#' ), +#' nSamples = 1000L, +#' inSample = FALSE, +#' ldScores = matrix(1, length(fm), 1, dimnames = list(NULL, "base_l2")), +#' ldScoreWeights = rep(1, length(fm)) +#' ) +#' annot <- fineMappingAnnotations( +#' qtlFineMappingExample, ref, +#' pipThreshold = 0.1 +#' ) +#' colnames(annot) +#' @importFrom checkmate assertMultiClass assertClass assertNumber +#' @importFrom rlang arg_match arg_match0 +#' @importFrom stringr str_extract str_flatten +#' @export +fineMappingAnnotations <- function( + x, + ldRef, + types = c("maxCpp", "sumPip", "credibleSet", "highPip"), + coverage = 0.95, + minPurity = NULL, + pipThreshold = 0.5, + tier = "candidate" +) { + assertMultiClass(x, c("QtlFineMappingResult", "GwasFineMappingResult")) + assertClass(ldRef, "LdStatistic") + chosenTypes <- arg_match(types, multiple = TRUE) + assertNumber(coverage, lower = 0, upper = 1) + assertNumber(minPurity, lower = 0, upper = 1, null.ok = TRUE) + assertNumber(pipThreshold, lower = 0, upper = 1) + chosenTier <- arg_match0(tier, c("candidate", "baseline")) + # The reference's variants, read off its ranges and alleles. + refTable <- .variantTable(ldRef) + tuples <- .enrAnnotationTuples(x) + columns <- map( + seq_len(nrow(tuples)), + .fmaTupleColumns, + x = x, + tuples = tuples, + refTable = refTable, + types = chosenTypes, + coverage = coverage, + minPurity = minPurity, + pipThreshold = pipThreshold + ) + mat <- .fmaDropEmptyColumns(exec(cbind, !!!columns)) + colTypes <- str_extract(colnames(mat), "[^|]+$") + meta <- tibble( + name = colnames(mat), + tier = rep(chosenTier, ncol(mat)), + type = if_else( + is_in(colTypes, c("maxCpp", "sumPip")), + "continuous", + "binary" + ) + ) + AnnotationMatrix( + mat, + GenomicRanges::granges(ldRef, use.mcols = FALSE), + meta, + genome = NULL + ) +} + +# One unit's columns over the reference's variants: its traits' PIPs and +# credible-set members, its variants aligned to the reference in one pass by +# the matching engine (.alignTablesToPanel()). +# @noRd +.fmaTupleColumns <- function( + k, + x, + tuples, + refTable, + types, + coverage, + minPurity, + pipThreshold +) { + rows <- .enrMatchRows(x, .enrAnnotationIdent(tuples, k)) + gr <- .fmrGatherVariants(x, rows) + md <- mcols(gr, use.names = FALSE) + at <- .alignTablesToPanel(.variantTable(gr), refTable) + values <- as.numeric(md$pip %||% rep(NA_real_, length(gr))) + hit <- !is.na(at) & !is.na(values) + M <- .variantTableSize(refTable) + maxPip <- .fmaScatter(M, at[hit], values[hit], "max") + out <- list( + maxCpp = maxPip, + sumPip = .fmaScatter(M, at[hit], values[hit], "sum"), + credibleSet = if (is_in("credibleSet", types)) { + .fmaCredibleSetColumn(md, at, M, coverage, minPurity) + }, + highPip = as.numeric(maxPip >= pipThreshold) + )[types] + named <- set_names(out, str_c(.fmaUnitName(tuples, k), "|", types)) + exec(cbind, !!!named) +} + +# A reference-length vector holding the largest (`f = "max"`) or the sum +# (`"sum"`) of the values at each reference index `at`, 0 where none falls. +#' @importFrom dplyr summarise +#' @noRd +.fmaScatter <- function(M, at, values, f) { + combine <- switch(f, max = max, sum = sum) + byIndex <- tibble(at = at, value = values) |> + summarise(value = combine(.data$value), .by = "at") + replace(numeric(M), byIndex$at, byIndex$value) +} + +# 1 for the reference variants (at their indices `at`) in a credible set of +# any of the unit's traits at `coverage`, as credibleSets() reads the +# credible-set columns `md` hold. +# @noRd +.fmaCredibleSetColumn <- function(md, at, M, coverage, minPurity) { + out <- numeric(M) + csCol <- str_c("cs_", coverage * 100) + if (!is_in(csCol, colnames(md))) { + return(out) + } + labels <- as.character(md[[csCol]]) + labelled <- !is.na(labels) & + str_length(labels) > 0L & + !str_detect(labels, "_0$") + purCol <- str_c(csCol, "_purity") + hasPurity <- is_in(purCol, colnames(md)) + if (!is.null(minPurity) && !hasPurity) { + warn(glue( + "credibleSets: no purity column '{purCol}' for coverage ", + "{coverage}; minPurity filter skipped." + )) + } + pure <- if (!is.null(minPurity) && hasPurity) { + purity <- as.numeric(md[[purCol]]) + !is.na(purity) & purity >= minPurity + } else { + TRUE + } + members <- at[labelled & pure] + replace(out, members[!is.na(members)], 1) +} + +# The unit's name: its study, context and method, without an axis the +# collection does not have. +# @noRd +.fmaUnitName <- function(tuples, k) { + axes <- map_chr( + c("qtlStudy", "qtlContext", "qtlMethod"), + .fmaTupleAxis, + tuples = tuples, + k = k + ) + str_flatten(axes[!is.na(axes)], "|") +} + +# @noRd +.fmaTupleAxis <- function(column, tuples, k) { + as.character(tuples[[column]][[k]]) +} + +# The columns with at least one non-zero entry, warning about the rest. +# @noRd +.fmaDropEmptyColumns <- function(mat) { + empty <- colSums(mat != 0) == 0 + if (!any(empty)) { + return(mat) + } + warn(glue( + "fineMappingAnnotations: dropping {sum(empty)} column(s) that are ", + "zero for every variant of the LD reference: ", + "{str_flatten(utils::head(colnames(mat)[empty], 5L), ', ')}." + )) + mat[, !empty, drop = FALSE] +} diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 7643d9cf..56e9e663 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -78,54 +78,6 @@ snpsPerBlock <- function(snpInfo, ldBlocks) { sqrt(enrichmentVar) } -#' @title Compute Baseline Annotation Enrichment Quantities -#' @description Given tau coefficients and a baseline annotation matrix, compute -#' the full set of enrichment quantities: propH2, propSnps, enrichment ratio, -#' enrichment SE (from jackknife or delta method), and p-value. -#' @param tau Numeric vector of per-annotation regression coefficients. -#' @param tauSe Numeric vector of SE for tau. -#' @param annotationJackknifeCoefs Numeric matrix (nBlocks x nAnnotations) of -#' jackknife block-level tau values, or NULL. -#' @param baselineMat Numeric matrix (nSnps x nAnnotations). -#' @param annotNames Character vector of annotation names. -#' @param h2 Numeric scalar, total estimated h2. -#' @return A tibble with columns: annotation, tau, tauSe, enrichment, -#' enrichmentSe, enrichmentP, propH2, propSnps. -#' @keywords internal -computeBaselineEnrichment <- function( - tau, - tauSe, - annotationJackknifeCoefs, - baselineMat, - annotNames, - h2 -) { - M <- nrow(baselineMat) - M_a <- colSums(baselineMat) - propSnps <- M_a / M - propH2 <- (tau * M_a) / h2 - # Enrichment ratio (propH2 / propSnps) = tau * M / h2. - enrichment <- tau * M / h2 - enrichmentSe <- .baselineEnrichmentSe( - annotationJackknifeCoefs, - tauSe, - M_a, - M, - h2 - ) - enrichmentP <- .zToPvalue(enrichment / enrichmentSe) - tibble( - annotation = annotNames, - tau = unname(tau), - tauSe = unname(tauSe), - enrichment = unname(enrichment), - enrichmentSe = unname(enrichmentSe), - enrichmentP = unname(enrichmentP), - propH2 = unname(propH2), - propSnps = unname(propSnps) - ) -} - # ============================================================================= # Genome build utilities # ============================================================================= @@ -432,6 +384,126 @@ NULL } } +# The baseline design all four estimators fit, NULL when unstratified: the +# user's baseline columns, with an all-ones "base" column put first unless +# they already span it (a partition of the genome does; one annotation +# alone, or a few that leave variants uncovered, do not). Without the base, +# the variants no baseline annotation covers would be modelled as carrying +# no heritability, and each annotation's coefficient would absorb the +# genome-wide signal instead of its excess over it. Adding it to a baseline +# that spans it would make the design singular. `userCols` records which +# columns are the user's. +# @noRd +.h2DesignMat <- function(annotations) { + baselineMat <- .h2BaselineMat(annotations) + if (is.null(baselineMat)) { + return(NULL) + } + A <- if (.h2SpansOnes(baselineMat)) { + baselineMat + } else { + cbind(base = 1, baselineMat) + } + `attr<-`( + A, + "userCols", + match(colnames(baselineMat), colnames(A)) + ) +} + +# TRUE when the all-ones vector lies in the column span of `B`, by least +# squares on B'B (pivoted, so overlapping or duplicated columns do no harm), +# which keeps a genome-wide B from being copied into a QR. +# @noRd +.h2SpansOnes <- function(B) { + decomp <- qr(crossprod(B)) + beta <- coalesce(qr.coef(decomp, colSums(B)), 0) + max(abs(1 - as.vector(B %*% beta))) < 1e-6 +} + +# The partitioned heritabilities, enrichment and per-annotation coefficients +# of a stratified fit, reported for the user's baseline annotations alone, +# from its per-variant-effect coefficients `tau` over the design `A` and their +# delete-one-block values `tauBlocks` (folds x columns). Annotations overlap +# in general -- the base overlaps every one -- so an annotation's +# heritability is (A'A tau)_a, not tau_a M_a, and the total is 1'A tau. +# @noRd +.h2StratifiedReport <- function(A, tau, tauBlocks) { + user <- attr(A, "userCols") + AtA <- crossprod(A) + size <- colSums(A) + propSnps <- size[user] / nrow(A) + propH2 <- as.vector(AtA %*% tau)[user] / sum(size * tau) + enrichment <- propH2 / propSnps + blockH2 <- (tauBlocks %*% AtA)[, user, drop = FALSE] + blockEnrichment <- sweep( + blockH2 / as.vector(tauBlocks %*% size), + 2L, + propSnps, + "/" + ) + enrichmentSe <- apply(blockEnrichment, 2L, .jackknifeSeFromLoo) + tauSe <- apply(tauBlocks, 2L, .jackknifeSeFromLoo)[user] + list( + tau = tau[user], + tauSe = tauSe, + annotationJackknifeCoefs = tauBlocks[, user, drop = FALSE], + enrichment = tibble( + annotation = colnames(A)[user], + tau = unname(tau[user]), + tauSe = unname(tauSe), + enrichment = unname(enrichment), + enrichmentSe = unname(enrichmentSe), + enrichmentP = unname( + pnorm(abs(enrichment - 1) / enrichmentSe, lower.tail = FALSE) * + 2 + ), + propH2 = unname(propH2), + propSnps = unname(propSnps) + ) + ) +} + +# The result of a stratified or unstratified fit: `tau` and `tauBlocks` over +# the design `A` (NULL when unstratified, where the heritability stands in +# for the coefficient). +# @noRd +.h2FitResult <- function( + h2, + h2Se, + intercept, + interceptSe, + A, + tau, + tauBlocks, + localDf, + scoreStats +) { + if (is.null(A)) { + jkRes <- list( + se = c(h2Se, interceptSe), + tauSe = h2Se, + annotationJackknifeCoefs = NULL + ) + return(.h2Result(h2, jkRes, intercept, h2, localDf, NULL, scoreStats)) + } + report <- .h2StratifiedReport(A, tau, tauBlocks) + jkRes <- list( + se = c(h2Se, interceptSe), + tauSe = report$tauSe, + annotationJackknifeCoefs = report$annotationJackknifeCoefs + ) + .h2Result( + h2, + jkRes, + intercept, + report$tau, + localDf, + report$enrichment, + scoreStats + ) +} + # Per-block whitened statistics x_i = (u_i'z)/sqrt(lam_i) and stratified # eigenvalue scores l_{ia} = sum_j A_{ja} V_{ji}^2 (all-ones column when # unstratified), plus the candidate annotations' scores, from the block's @@ -620,23 +692,6 @@ NULL sqrt((n - 1) / n * sum((v - mean(v))^2)) } -# tau / tauSe / annotationJackknifeCoefs for the enrichment framework -# (univariate: tau = h2). -.lderEnrichParts <- function(fit, jk, baselineMat) { - if (is.null(baselineMat)) { - return(list( - tau = fit$h2, - tauSe = jk$h2Se, - annotationJackknifeCoefs = NULL - )) - } - list( - tau = fit$tau, - tauSe = jk$tauSe, - annotationJackknifeCoefs = jk$annotationJackknifeCoefs - ) -} - # Local heritability for one block: single-slope fit with intercept fixed at # the global inflation; h2Local = tau * (block directions). .lderLocalBlock <- function(bs, b, N, a) { @@ -672,40 +727,14 @@ NULL ) } -# Weighted score z for one candidate: standardized weighted covariance of the -# baseline residual with the candidate design column N*lam*l_ic. -.lderCandidateScore <- function(ldCandCol, lam, w, resid, N, keep) { - d <- N * lam[keep] * ldCandCol[keep] - sum(w[keep] * resid[keep] * d) / sqrt(sum(w[keep] * d^2)) -} - -# Jackknife (leave-one-block-out) correlation of the candidate score z's. -.lderScoreCor <- function(ldCand, lam, w, resid, N, blockId, nCand) { - if (nCand == 1) { - return(matrix(1, 1, 1)) - } - looRows <- map( - sort(unique(blockId)), - .lderLooBlockScores, - blockId = blockId, - ldCand = ldCand, - lam = lam, - w = w, - resid = resid, - N = N, - nCand = nCand - ) - looZ <- exec(rbind, !!!looRows) - R <- cor(looZ) - replace(R, is.na(R), 0) -} - -# LDER candidate-annotation score statistics against the fitted baseline. +# LDER candidate-annotation score statistics against the fitted baseline: +# the regression of chi2 = x^2 on mu = N lam (l_a tau) + N a + 1, scored for +# each candidate's column N lam l_c with the weights 1 / (2 mu^2) and the +# baseline and inflation as nuisance (.h2EfficientScoreBlocks()). .lderScoreStats <- function(blockStats, annotations, design, fit, N) { candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") - nCand <- ncol(candMat) - if (nCand == 0) { + if (ncol(candMat) == 0) { return(list(enrichment = NULL, scoreStats = NULL)) } lam <- design$lam @@ -714,21 +743,21 @@ NULL 1e-8 ) w <- 1 / (2 * mu^2) - resid <- design$x^2 - mu - ldCand <- exec(rbind, !!!map(blockStats, "ldCand")) - keepAll <- rep(TRUE, length(lam)) - scoreZ <- map_dbl( - seq_len(nCand), - .lderScoreForCand, - ldCand = ldCand, - lam = lam, - w = w, - resid = resid, - N = N, - keep = keepAll + blockCands <- map(blockStats, "ldCand") + ldCand <- exec(rbind, !!!blockCands) + Ub <- .h2EfficientScoreBlocks( + N * lam * ldCand, + cbind(N * lam * design$ldAnnot, N), + w, + w * (design$x^2 - mu), + design$blockId + ) + sc <- .h2BlockScoreStats(Ub) + .buildEnrichmentResult( + SummarizedExperiment::colData(candidate), + sc$scoreZ, + sc$R ) - R <- .lderScoreCor(ldCand, lam, w, resid, N, design$blockId, nCand) - .buildEnrichmentResult(SummarizedExperiment::colData(candidate), scoreZ, R) } lderUnivariate <- function( @@ -739,17 +768,8 @@ lderUnivariate <- function( local = FALSE ) { rough <- !inSample(eigenRef) - baselineMat <- .h2BaselineMat(annotations) - # One pass over the blocks, each decomposed only while its statistics are - # taken, so a reference read from a panel holds one block at a time. - blockStats <- map( - .ldEigenBlocks(eigenRef), - .lderBlockStats, - eigenRef = eigenRef, - z = z, - baselineMat = baselineMat, - candMat = .h2CandidateMat(annotations) - ) + baselineMat <- .h2DesignMat(annotations) + blockStats <- .lderAllBlockStats(eigenRef, z, baselineMat, annotations) design <- .lderDesign(blockStats, baselineMat) M <- length(design$x) fit <- .lderGetRes( @@ -763,14 +783,15 @@ lderUnivariate <- function( TRUE ) jk <- .lderJackknife(blockStats, baselineMat, n, M, design$M_a, rough, TRUE) - ep <- .lderEnrichParts(fit, jk, baselineMat) localDf <- if (local) .lderLocal(blockStats, n, fit$a) else NULL - .h2JackknifeResult( + .h2FitResult( h2 = fit$h2, + h2Se = jk$h2Se, intercept = fit$a, - se = c(jk$h2Se, jk$aSe), - ep = ep, - baselineMat = baselineMat, + interceptSe = jk$aSe, + A = baselineMat, + tau = fit$tau, + tauBlocks = jk$annotationJackknifeCoefs, localDf = localDf, scoreStats = .lderCandidateScores( blockStats, @@ -782,6 +803,21 @@ lderUnivariate <- function( ) } +# Each LD block's LDER statistics, in one pass over the blocks, each +# decomposed only while its statistics are taken, so a reference read from a +# panel holds one block at a time. +# @noRd +.lderAllBlockStats <- function(eigenRef, z, baselineMat, annotations) { + map( + .ldEigenBlocks(eigenRef), + .lderBlockStats, + eigenRef = eigenRef, + z = z, + baselineMat = baselineMat, + candMat = .h2CandidateMat(annotations) + ) +} + # LDER's score statistics for the candidate annotations; NULL when there are # none to test. # @noRd @@ -832,63 +868,6 @@ lderUnivariate <- function( ) } -# The result of an estimator jackknifed over its blocks (LDER, HDL): `se` -# holds the standard errors of h2 and of the intercept, and `ep` the -# enrichment parts (tau, tauSe, annotationJackknifeCoefs) that the -# per-annotation enrichment table is built from. -# @noRd -.h2JackknifeResult <- function( - h2, - intercept, - se, - ep, - baselineMat, - localDf, - scoreStats -) { - jkRes <- list( - se = se, - tauSe = ep$tauSe, - annotationJackknifeCoefs = ep$annotationJackknifeCoefs - ) - enrichmentDf <- .h2Enrichment( - baselineMat, - ep$tau, - ep$tauSe, - ep$annotationJackknifeCoefs, - h2 - ) - .h2Result(h2, jkRes, intercept, ep$tau, localDf, enrichmentDf, scoreStats) -} - -# Per-annotation enrichment table via the shared tau-based framework (used by -# HDL and LDER; g-LDSC builds its own from partitioned h2). NULL when -# unstratified. -.h2Enrichment <- function( - baselineMat, - tau, - tauSe, - annotationJackknifeCoefs, - h2 -) { - if (is.null(baselineMat)) { - return(NULL) - } - annotNames <- if (!is.null(colnames(baselineMat))) { - colnames(baselineMat) - } else { - str_c("annot_", seq_len(ncol(baselineMat))) - } - computeBaselineEnrichment( - tau, - tauSe, - annotationJackknifeCoefs, - baselineMat, - annotNames, - h2 - ) -} - #' @title g-LDSC: Generalized LD Score Regression #' @description Estimate heritability and functional enrichment by feasible #' generalized least squares (FGLS) on LD scores (Xiong et al. 2024). The @@ -918,11 +897,11 @@ lderUnivariate <- function( #' @importFrom stats var pnorm NULL -# Full annotation matrix A = [base (all-ones) | baseline columns]; the base -# column carries genome-wide h2 (est.h[1] = total). +# The annotation matrix A the LD-score estimators regress on: the baseline +# design (.h2DesignMat()), or the all-ones base alone when unstratified. .gldscAnnotMatrix <- function(annotations, M) { - baselineMat <- .h2BaselineMat(annotations) - if (is.null(baselineMat)) matrix(1, M, 1) else cbind(base = 1, baselineMat) + .h2DesignMat(annotations) %||% + matrix(1, M, 1, dimnames = list(NULL, "base")) } # Per-block design: the block's annotations, its stratified LD scores @@ -995,18 +974,16 @@ NULL # A block's candidate-score pieces. The score is taken against the FITTED # baseline residual, U_c = l_c' Omega^-1 (y - X coef), which is linear in # coef: keeping l_c' Omega^-1 y and l_c' Omega^-1 X lets the block's score be -# formed once the fit is known, without revisiting the block. Alongside, -# I_c = l_c' Omega^-1 l_c. NULL without candidates. +# formed once the fit is known, without revisiting the block. NULL without +# candidates. .gldscCandidatePieces <- function(om, ldCand, P, Py) { if (is.null(ldCand)) { return(NULL) } - Q <- crossprod(om$vectors, ldCand) - Qw <- Q / om$values + Qw <- crossprod(om$vectors, ldCand) / om$values list( Uy = as.vector(crossprod(Qw, Py)), - UX = crossprod(Qw, P), - I = colSums(Q * Qw) + UX = crossprod(Qw, P) ) } @@ -1017,12 +994,10 @@ NULL coef <- as.vector(solve(left + diag(ridge, nrow(left)), right)) tauAll <- coef / N tau <- tauAll[-1] - estH <- as.vector(crossprod(A) %*% tau) list( tau = tau, coef = coef, - estH = estH, - h2 = estH[1], + h2 = sum(colSums(A) * tau), intercept = N * tauAll[1] + 1 ) } @@ -1039,47 +1014,11 @@ NULL A = A, N = N ) - estHList <- map(loo, "estH") - estHBlocks <- exec(rbind, !!!estHList) - tauList <- map(loo, "tau") - jkCoefs <- exec(rbind, !!!tauList) - intLoo <- map_dbl(loo, "intercept") + taus <- map(loo, "tau") list( - h2Se = .jackknifeSeFromLoo(estHBlocks[, 1]), - intSe = .jackknifeSeFromLoo(intLoo), - tauSe = apply(jkCoefs, 2, .jackknifeSeFromLoo), - annotationJackknifeCoefs = jkCoefs, - estHBlocks = estHBlocks - ) -} - -# Enrichment for baseline (non-base) annotations from partitioned h2 est.h: -# propH2 = est.h_a / total, propSnps = M_a / M, enrichment = propH2 / propSnps. -.gldscEnrichmentDf <- function(fit, jk, baselineMat, annotNames, M) { - total <- fit$estH[1] - M_a <- colSums(baselineMat) - propSnps <- M_a / M - propH2 <- fit$estH[-1] / total - enrichment <- propH2 / propSnps - eBlocks <- sweep( - jk$estHBlocks[, -1, drop = FALSE] / jk$estHBlocks[, 1], - 2, - propSnps, - "/" - ) - nB <- nrow(eBlocks) - eSe <- sqrt(apply(eBlocks, 2, var) * (nB - 1)^2 / nB) - tibble( - annotation = annotNames, - tau = unname(fit$tau[-1]), - tauSe = unname(jk$tauSe[-1]), - enrichment = unname(enrichment), - enrichmentSe = unname(eSe), - enrichmentP = unname( - pnorm(abs(enrichment - 1) / eSe, lower.tail = FALSE) * 2 - ), - propH2 = unname(propH2), - propSnps = unname(propSnps) + h2Se = .jackknifeSeFromLoo(map_dbl(loo, "h2")), + intSe = .jackknifeSeFromLoo(map_dbl(loo, "intercept")), + annotationJackknifeCoefs = exec(rbind, !!!taus) ) } @@ -1109,35 +1048,83 @@ NULL ) } -# One block's candidate scores at the fitted coefficients, against the -# fitted baseline GLS residual r = y - X coef: U_c = l_c' Omega^-1 r and -# I_c = l_c' Omega^-1 l_c. -.gldscCandidateBlock <- function(cb, coef) { - list(U = cb$cand$Uy - as.vector(cb$cand$UX %*% coef), I = cb$cand$I) +# One block's score for each candidate, against the fitted baseline GLS +# residual r = y - X coef, with the candidate's LD scores l_c first +# residualized on the design: U_c = (l_c - X beta_c)' Omega^-1 r, beta_c = +# (X' Omega^-1 X)^-1 X' Omega^-1 l_c. Summed over blocks the adjustment +# vanishes (X' Omega^-1 r = 0 at the fit); block by block it does not, and +# it is what makes the blocks' scores the efficient ones the jackknife +# variance is taken over. +.gldscCandidateBlock <- function(cb, coef, beta) { + U <- cb$cand$Uy - as.vector(cb$cand$UX %*% coef) + Xr <- cb$R - as.vector(cb$L %*% coef) + U - as.vector(crossprod(beta, Xr)) } -# sHDL-style candidate score statistics + jackknife score correlation: -# scoreZ = sum_b U_c / sqrt(sum_b I_c), at the real fitted coefficients (not -# a refit). +# Candidate score statistics at the real fitted coefficients (not a refit), +# calibrated by the blocks' own spread (.h2BlockScoreStats()) rather than by +# the model information l_c' Omega^-1 l_c, which ignored the estimated +# baseline and trusted the plug-in Omega. .gldscScoreStats <- function(contrib, coef) { - per <- map(contrib, .gldscCandidateBlock, coef = coef) - U <- reduce(map(per, "U"), `+`) - I <- reduce(map(per, "I"), `+`) - scoreZ <- U / sqrt(pmax(I, 1e-10)) - R <- if (length(U) == 1L) { + left <- reduce(map(contrib, "L"), `+`) + lX <- reduce(map(contrib, .gldscCandidateCross), `+`) + ridge <- 1e-8 * mean(abs(diag(left))) + beta <- solve(left + diag(ridge, nrow(left)), lX) + blockScores <- map( + contrib, + .gldscCandidateBlock, + coef = coef, + beta = beta + ) + .h2BlockScoreStats(exec(rbind, !!!blockScores)) +} + +# One block's candidate cross-products X' Omega^-1 l_c, design by candidate. +# @noRd +.gldscCandidateCross <- function(cb) { + t(cb$cand$UX) +} + +# Each LD block's efficient score for every candidate (a blocks x candidates +# matrix). An observation i -- a variant, or an eigen-direction -- adds +# gTilde_ic e_i, where e_i is its score residual (weighted residual, or the +# likelihood's), gC[i, c] the derivative of its modelled mean or variance in +# the candidate's parameter, and gTilde that derivative residualized on the +# nuisance derivatives G under the information weights `info`: +# gTilde = gC - G (G' info G)^-1 G' info gC. Residualizing is what makes the +# test account for the baseline and intercept having been estimated -- a +# candidate overlapping the baseline otherwise picks up the baseline's fitted +# signal -- and it needs no refit. `blockOf` gives each observation's block. +# @noRd +.h2EfficientScoreBlocks <- function(gC, G, info, e, blockOf) { + grad <- as.matrix(gC) + gtg <- crossprod(G, G * info) + ridge <- 1e-8 * mean(abs(diag(gtg))) + beta <- solve(gtg + diag(ridge, ncol(G)), crossprod(G, grad * info)) + rowsum((grad - G %*% beta) * e, blockOf) +} + +# Candidate score statistics from each LD block's score (a blocks x +# candidates matrix Ub): z_c = U_c / sqrt(V_c) with U_c = sum_b Ub[b, c] and +# V_c = nB / (nB - 1) sum_b (Ub[b, c] - U_c / nB)^2, the delete-one-block +# jackknife variance of the sum. Taking the variance from the blocks makes the +# test valid however wrong the regression weights are -- correlated +# residuals, a misspecified Omega -- as the heritability's own jackknife SE +# is. The candidates' correlation is that of their block scores. +# @noRd +.h2BlockScoreStats <- function(Ub) { + blockScores <- as.matrix(Ub) + nB <- nrow(blockScores) + U <- colSums(blockScores) + centered <- sweep(blockScores, 2L, U / nB) + V <- nB / (nB - 1) * colSums(centered^2) + R <- if (ncol(blockScores) == 1L) { matrix(1, 1, 1) } else { - looRows <- map( - seq_along(per), - .gldscScoreLooRow, - per = per, - U = U, - I = I - ) - Rc <- cor(exec(rbind, !!!looRows)) + Rc <- stats::cov2cor(crossprod(centered)) replace(Rc, is.na(Rc), 0) } - list(scoreZ = scoreZ, R = R) + list(scoreZ = unname(U / sqrt(pmax(V, .Machine$double.xmin))), R = R) } gldscUnivariate <- function( @@ -1183,7 +1170,7 @@ gldscUnivariate <- function( right <- reduce(map(contrib, "R"), `+`) fit <- .gldscEstimate(left, right, A, n) jk <- .gldscJackknife(contrib, left, right, A, n) - .gldscResult(fit, jk, annotations, contrib, local, n, M) + .gldscResult(fit, jk, annotations, contrib, local, n, M, A) } # The candidate-annotation score statistics, when candidates were supplied. @@ -1204,42 +1191,17 @@ gldscUnivariate <- function( } # Assemble the gldscUnivariate return (enrichment, local, candidate scores). -.gldscResult <- function(fit, jk, annotations, contrib, local, n, M) { - baselineMat <- .h2BaselineMat(annotations) - localDf <- if (local) .gldscLocal(contrib, n) else NULL - enrichmentDf <- if (is.null(baselineMat)) { - NULL - } else { - .gldscEnrichmentDf( - fit, - jk, - baselineMat, - SummarizedExperiment::colData( - baselineAnnotations(annotations) - )$name, - M - ) - } - scoreStats <- .gldscCandidateScores(annotations, contrib, fit) - tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] - tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] - jkRes <- list( - se = c(jk$h2Se, jk$intSe), - tauSe = tauSe, - annotationJackknifeCoefs = if (is.null(baselineMat)) { - NULL - } else { - jk$annotationJackknifeCoefs[, -1, drop = FALSE] - } - ) - .h2Result( - fit$h2, - jkRes, - fit$intercept, - tau, - localDf, - enrichmentDf, - scoreStats +.gldscResult <- function(fit, jk, annotations, contrib, local, n, M, A) { + .h2FitResult( + h2 = fit$h2, + h2Se = jk$h2Se, + intercept = fit$intercept, + interceptSe = jk$intSe, + A = if (is.null(.h2BaselineMat(annotations))) NULL else A, + tau = fit$tau, + tauBlocks = jk$annotationJackknifeCoefs, + localDf = if (local) .gldscLocal(contrib, n) else NULL, + scoreStats = .gldscCandidateScores(annotations, contrib, fit) ) } @@ -1360,7 +1322,8 @@ NULL bstar = bstar, blockId = blockId, ldAnnotScaled = sweep(ldAnnot, 2, M_a, "/"), - M_a = M_a + M_a = M_a, + baseAdded = !is_in(1L, attr(baselineMat, "userCols")) ) } @@ -1369,7 +1332,18 @@ NULL # keeps the L-BFGS-B finite differences well conditioned. .hdlFit <- function(design, n, nSamples, warnOnBound = TRUE) { nTau <- ncol(design$ldAnnotScaled) - lower <- c(rep(0, nTau), 0) + # Beside an added base column an annotation's parameter is its excess + # over the genome-wide rate, which a depleted annotation makes negative; + # only the base, and the columns of a baseline that spans the genome on + # its own, are heritabilities bounded below by 0. + lower <- c( + if (isTRUE(design$baseAdded)) { + c(0, rep(-1, nTau - 1L)) + } else { + rep(0, nTau) + }, + 0 + ) upper <- c(rep(1, nTau), 10) opt <- optim( c(rep(0.1, nTau), 1), @@ -1472,23 +1446,6 @@ NULL ) } -# Convert fitted per-annotation h2 to per-SNP tau = h2_a / M_a for the -# enrichment framework (univariate: tau = h2 scalar, no blocks). -.hdlEnrichParts <- function(ft, jk, design, baselineMat) { - if (is.null(baselineMat)) { - return(list( - tau = ft$h2, - tauSe = jk$h2Se, - annotationJackknifeCoefs = NULL - )) - } - list( - tau = ft$h2a / design$M_a, - tauSe = jk$h2aSe / design$M_a, - annotationJackknifeCoefs = sweep(jk$h2aBlocks, 2, design$M_a, "/") - ) -} - # ============================================================================= # HDL local heritability + sHDL candidate score test # ============================================================================= @@ -1552,79 +1509,45 @@ NULL ) } -# sHDL score z for one candidate annotation: score U_c = sum_i g_ic * -# (bstar_i^2/lamh2_i^2 - 1/lamh2_i) with g_ic = dlamh2_i/dh2_c, standardized by -# sqrt(Var(U_c)) = sqrt(2 sum_i g_ic^2 / lamh2_i^2). -.shdlCandidateScore <- function( - ldCandCol, - M_c, - lam, - lamh2, - scoreResid, - nSamples, - keep -) { - g <- ldCandCol[keep] * lam[keep]^2 / M_c - lam[keep] / nSamples - lh <- lamh2[keep] - sum(g * scoreResid[keep]) / sqrt(2 * sum(g^2 / lh^2)) -} - -# sHDL candidate-annotation score statistics + jackknife score correlation. -.shdlStratified <- function(blockData, nPanel, annotations, design, lamh2) { +# sHDL candidate-annotation score statistics. Each eigen-direction's rotated +# effect has modelled variance v_i = lamh2_i, and the likelihood's score for +# a candidate's heritability is sum_i g_ic (bstar_i^2 / v_i^2 - 1 / v_i), +# with g_ic = dv_i/dh2_c = l_ic lam_i^2 / M_c - lam_i / nPanel and +# information weight 2 / v_i^2. The baseline heritabilities and the intercept +# are the nuisance (.h2EfficientScoreBlocks()), with derivatives +# l_ia lam_i^2 / M_a - lam_i / nPanel and lam_i / n. +.shdlStratified <- function(blockData, nPanel, annotations, design, lamh2, n) { candidate <- testedAnnotations(annotations) candMat <- assay(candidate, "annotations") - nCand <- ncol(candMat) - if (nCand == 0) { + if (ncol(candMat) == 0) { return(list(enrichment = NULL, scoreStats = NULL)) } - M_c <- colSums(candMat) - ldCand <- exec(rbind, !!!map(blockData, "ldCand")) - scoreResid <- design$bstar^2 / lamh2^2 - 1 / lamh2 - keepAll <- rep(TRUE, length(lamh2)) - scoreZ <- map_dbl( - seq_len(nCand), - .shdlScoreForCand, - ldCand = ldCand, - M_c = M_c, - lam = design$lam, - lamh2 = lamh2, - scoreResid = scoreResid, - nSamples = nPanel, - keep = keepAll - ) - R <- .shdlScoreCor(ldCand, M_c, design, lamh2, scoreResid, nPanel, nCand) - .buildEnrichmentResult(SummarizedExperiment::colData(candidate), scoreZ, R) -} - -# Jackknife (leave-one-block-out) correlation of the candidate score z's. -.shdlScoreCor <- function( - ldCand, - M_c, - design, - lamh2, - scoreResid, - nSamples, - nCand -) { - if (nCand == 1) { - return(matrix(1, 1, 1)) - } - blocks <- sort(unique(design$blockId)) - looRows <- map( - blocks, - .shdlLooBlockScores, - blockId = design$blockId, - ldCand = ldCand, - M_c = M_c, - lam = design$lam, - lamh2 = lamh2, - scoreResid = scoreResid, - nSamples = nSamples, - nCand = nCand - ) - looZ <- exec(rbind, !!!looRows) - R <- cor(looZ) - replace(R, is.na(R), 0) + lam <- design$lam + blockCands <- map(blockData, "ldCand") + ldCand <- exec(rbind, !!!blockCands) + gC <- .shdlGradient(sweep(ldCand, 2L, colSums(candMat), "/"), lam, nPanel) + G <- cbind(.shdlGradient(design$ldAnnotScaled, lam, nPanel), lam / n) + Ub <- .h2EfficientScoreBlocks( + gC, + G, + 2 / lamh2^2, + design$bstar^2 / lamh2^2 - 1 / lamh2, + design$blockId + ) + sc <- .h2BlockScoreStats(Ub) + .buildEnrichmentResult( + SummarizedExperiment::colData(candidate), + sc$scoreZ, + sc$R + ) +} + +# The derivative of each eigen-direction's modelled variance in an +# annotation's heritability, from the annotation's LD scores scaled by its +# size: l_ia lam_i^2 / M_a - lam_i / nPanel. +# @noRd +.shdlGradient <- function(scaled, lam, nPanel) { + scaled * lam^2 - lam / nPanel } # ============================================================================= @@ -1640,7 +1563,7 @@ hdlUnivariate <- function( ) { M <- length(eigenRef) nPanel <- ldPanelNSamples(eigenRef) - baselineMat <- .h2BaselineMat(annotations) + baselineMat <- .h2DesignMat(annotations) # One pass over the blocks, each decomposed only while its data are taken. blockData <- map( .ldEigenBlocks(eigenRef), @@ -1654,14 +1577,15 @@ hdlUnivariate <- function( design <- .hdlDesign(blockData, M, baselineMat) ft <- .hdlFit(design, n, nPanel) jk <- .hdlJackknife(blockData, M, baselineMat, n, nPanel) - ep <- .hdlEnrichParts(ft, jk, design, baselineMat) localDf <- if (local) .hdlLocal(blockData, n, nPanel, ft$int, M) else NULL - .h2JackknifeResult( + .h2FitResult( h2 = ft$h2, + h2Se = jk$h2Se, intercept = ft$int, - se = c(jk$h2Se, jk$intSe), - ep = ep, - baselineMat = baselineMat, + interceptSe = jk$intSe, + A = baselineMat, + tau = ft$h2a / design$M_a, + tauBlocks = sweep(jk$h2aBlocks, 2L, design$M_a, "/"), localDf = localDf, scoreStats = .hdlCandidateScores( blockData, @@ -1682,7 +1606,7 @@ hdlUnivariate <- function( return(NULL) } lamh2 <- .hdlBaselineVar(design, ft, n, nPanel) - .shdlStratified(blockData, nPanel, annotations, design, lamh2)$scoreStats + .shdlStratified(blockData, nPanel, annotations, design, lamh2, n)$scoreStats } @@ -1784,27 +1708,84 @@ sldscUnivariate <- function( ) { M <- length(ldRef) chi2 <- z^2 - baselineMat <- .h2BaselineMat(annotations) - # Same design g-LDSC uses: an all-ones "base" annotation ahead of the - # baseline columns, so `crossprod(A)` is the annotation overlap matrix. + # Same design g-LDSC uses (.h2DesignMat()), so `crossprod(A)` is the + # annotation overlap matrix. A <- .gldscAnnotMatrix(annotations, M) - scores <- .sldscScoreMatrix(ldRef, baselineMat, M) - baseScore <- scores[, 1L] + scores <- .sldscScoreMatrix(ldRef, A) + # The weights read the stored base score whatever the design holds. + baseScore <- as.vector(mcols(ldRef)$ldScores[, 1L]) blockIdx <- .sldscBlockIndex(ldRef) fit <- .sldscFit(chi2, scores, baseScore, n, A, nIter) jk <- .sldscJackknife(chi2, scores, baseScore, n, A, nIter, blockIdx) - .sldscResult(fit, jk, annotations, baselineMat, chi2, baseScore, local, M) + scoreStats <- .sldscCandidateScores(fit, ldRef, annotations, blockIdx) + .h2FitResult( + h2 = fit$h2, + h2Se = jk$h2Se, + intercept = fit$intercept, + interceptSe = jk$intSe, + A = if (is.null(.h2BaselineMat(annotations))) NULL else A, + tau = fit$tau, + tauBlocks = jk$annotationJackknifeCoefs, + localDf = if (local) .sldscLocal(chi2, baseScore, fit) else NULL, + scoreStats = scoreStats + ) } -# The design's LD-score columns: the base score first, then one stratified -# score per baseline annotation. Stratified scores come from each block's LD, -# the same source g-LDSC uses, and take ldsc's unbiased r^2 as the stored -# base score does: ldsc applies it to every annotation column. +# The candidate annotations' score statistics, NULL without candidates: each +# candidate's stratified LD score is scored against the fitted residual in +# the fit's final weights, with the fitted design as nuisance +# (.h2EfficientScoreBlocks()). # @noRd -.sldscScoreMatrix <- function(ldRef, baselineMat, M) { - base <- as.vector(mcols(ldRef)$ldScores[, 1L]) - if (is.null(baselineMat)) { - return(matrix(base, ncol = 1L, dimnames = list(NULL, "base_l2"))) +.sldscCandidateScores <- function(fit, ldRef, annotations, blockIdx) { + candMat <- .h2CandidateMat(annotations) + if (is.null(candMat)) { + return(NULL) + } + if (!.ldScoreHasLd(ldRef)) { + abort(str_c( + "S-LDSC's candidate-annotation score test needs each LD block's ", + "LD to form the candidates' LD scores. Build the reference from ", + "a genotype panel, or with `buildLdScore(keepLdMatrices = TRUE)`." + )) + } + parts <- attr(fit, "scoreParts") + ldCand <- .h2StratifiedScores(ldRef, candMat)[parts$keep, , drop = FALSE] + blockOf <- rep(seq_along(blockIdx), lengths(blockIdx))[ + order(list_c(blockIdx)) + ] + Ub <- .h2EfficientScoreBlocks( + ldCand, + parts$design, + parts$w, + parts$w * parts$resid, + blockOf[parts$keep] + ) + sc <- .h2BlockScoreStats(Ub) + list( + z = sc$scoreZ, + R = sc$R, + annotationNames = SummarizedExperiment::colData( + testedAnnotations(annotations) + )$name + ) +} + +# The design's LD-score columns, one per column of the annotation matrix `A` +# (.gldscAnnotMatrix()): the stored base score for the base column, and a +# stratified score for each baseline annotation. Stratified scores come from +# each block's LD, the same source g-LDSC uses, and take ldsc's unbiased r^2 +# as the stored base score does: ldsc applies it to every annotation column. +# @noRd +.sldscScoreMatrix <- function(ldRef, A) { + base <- matrix( + as.vector(mcols(ldRef)$ldScores[, 1L]), + ncol = 1L, + dimnames = list(NULL, "base_l2") + ) + hasBase <- identical(colnames(A)[[1L]], "base") + baselineMat <- if (hasBase) A[, -1L, drop = FALSE] else A + if (ncol(baselineMat) == 0L) { + return(base) } if (!.ldScoreHasLd(ldRef)) { abort(str_c( @@ -1813,7 +1794,8 @@ sldscUnivariate <- function( "panel, or with `buildLdScore(keepLdMatrices = TRUE)`." )) } - cbind(base_l2 = base, .h2StratifiedScores(ldRef, baselineMat)) + stratified <- .h2StratifiedScores(ldRef, baselineMat) + if (hasBase) cbind(base, stratified) else stratified } # Annotation-stratified LD scores sum_k r^2_jk a_k under ldsc's unbiased r^2, @@ -1935,7 +1917,25 @@ sldscUnivariate <- function( intercept = intercept, w0 = w0 ) - .sldscCoefToFit(c(step2$coef, intercept), n, A) + fit <- .sldscCoefToFit(c(step2$coef, intercept), n, A) + `attr<-`( + fit, + "scoreParts", + .sldscUnivariateScoreParts(chi2, scores, intercept, step2) + ) +} + +# What the candidate score test reads (.sldscCandidateScores()) of a +# univariate fit: the step-2 regression, with the intercept step 1 estimated +# as a column so the candidates are residualized on it too. +# @noRd +.sldscUnivariateScoreParts <- function(chi2, scores, intercept, step2) { + list( + keep = rep(TRUE, length(chi2)), + design = cbind(scores, 1), + w = step2$w, + resid = as.vector(chi2 - intercept - scores %*% step2$coef) + ) } # @noRd @@ -1958,7 +1958,18 @@ sldscUnivariate <- function( xTot <- rowSums(scores) hsq <- .sldscAggregateH2(chi2, xTot, n, M) w <- .sldscWeights(xTot, baseScore, n, M, hsq, 1) - .sldscCoefToFit(.sldscWlsCoef(cbind(scores, 1), chi2, w), n, A) + design <- cbind(scores, 1) + coef <- .sldscWlsCoef(design, chi2, w) + `attr<-`( + .sldscCoefToFit(coef, n, A), + "scoreParts", + list( + keep = keep, + design = design, + w = w, + resid = as.vector(chi2 - design %*% coef) + ) + ) } # Two IRWLS passes, matching the original ldsc's `for i in range(2)`. @@ -2000,7 +2011,8 @@ sldscUnivariate <- function( coef <- .sldscWlsCoef(design, y, w) list( coef = coef[seq_len(ncol(scores))], - intercept = if (freeIntercept) coef[[length(coef)]] else intercept + intercept = if (freeIntercept) coef[[length(coef)]] else intercept, + w = w ) } @@ -2028,11 +2040,9 @@ sldscUnivariate <- function( .sldscCoefToFit <- function(coef, n, A) { nS <- ncol(A) tau <- coef[seq_len(nS)] / n - estH <- as.vector(crossprod(A) %*% tau) list( tau = tau, - h2 = estH[[1L]], - estH = estH, + h2 = sum(colSums(A) * tau), intercept = coef[[nS + 1L]], coef = coef ) @@ -2051,15 +2061,11 @@ sldscUnivariate <- function( A = A, nIter = nIter ) - jkCoefs <- exec(rbind, !!!map(loo, "tau")) - estHBlocks <- exec(rbind, !!!map(loo, "estH")) - intLoo <- map_dbl(loo, "intercept") + taus <- map(loo, "tau") list( - h2Se = .jackknifeSeFromLoo(estHBlocks[, 1L]), - intSe = .jackknifeSeFromLoo(intLoo), - tauSe = apply(jkCoefs, 2, .jackknifeSeFromLoo), - annotationJackknifeCoefs = jkCoefs, - estHBlocks = estHBlocks + h2Se = .jackknifeSeFromLoo(map_dbl(loo, "h2")), + intSe = .jackknifeSeFromLoo(map_dbl(loo, "intercept")), + annotationJackknifeCoefs = exec(rbind, !!!taus) ) } @@ -2078,45 +2084,6 @@ sldscUnivariate <- function( ) } -# @noRd -.sldscResult <- function( - fit, - jk, - annotations, - baselineMat, - chi2, - baseScore, - local, - M -) { - localDf <- if (local) .sldscLocal(chi2, baseScore, fit) else NULL - enrichmentDf <- if (is.null(baselineMat)) { - NULL - } else { - .gldscEnrichmentDf( - fit, - jk, - baselineMat, - SummarizedExperiment::colData( - baselineAnnotations(annotations) - )$name, - M - ) - } - tau <- if (is.null(baselineMat)) fit$h2 else fit$tau[-1] - tauSe <- if (is.null(baselineMat)) jk$h2Se else jk$tauSe[-1] - jkRes <- list( - se = c(jk$h2Se, jk$intSe), - tauSe = tauSe, - annotationJackknifeCoefs = if (is.null(baselineMat)) { - NULL - } else { - jk$annotationJackknifeCoefs[, -1, drop = FALSE] - } - ) - .h2Result(fit$h2, jkRes, fit$intercept, tau, localDf, enrichmentDf, NULL) -} - # Per-variant local h2 contribution: the fitted non-intercept signal spread # over the variant's own LD score. # @noRd @@ -2194,12 +2161,13 @@ sldscUnivariate <- function( length(ldRef), glue("study '{studyName}'") ) - .h2CheckPositions(entry, ldRef, studyName) + .h2CheckPositions(entry, ldRef, glue("study '{studyName}'")) if (is.null(annotations)) { return(invisible(TRUE)) } checkGenomeBuild(ldRef, annotations) .h2CheckVariantCount(nrow(annotations), length(ldRef), "`annotations`") + .h2CheckPositions(rowRanges(annotations), ldRef, "`annotations`") invisible(TRUE) } @@ -2236,21 +2204,23 @@ sldscUnivariate <- function( abort(msg) } -# Element-wise coordinate check. Coordinates are compared rather than variant -# ids because the two sides routinely name the same variant differently -# (rsid vs chr:pos:A2:A1), while the same variant always sits at the same -# coordinate. -# @noRd -.h2CheckPositions <- function(entry, ldRef, studyName) { - same <- as.character(seqnames(entry)) == as.character(seqnames(ldRef)) & - start(entry) == start(ldRef) +# Element-wise coordinate check of `gr` (a study's variants, or the +# annotation rows) against the reference, `what` naming it. Coordinates are +# compared rather than variant ids because the two sides routinely name the +# same variant differently (rsid vs chr:pos:A2:A1), while the same variant +# always sits at the same coordinate. +#' @importFrom SummarizedExperiment rowRanges +#' @noRd +.h2CheckPositions <- function(gr, ldRef, what) { + same <- as.character(seqnames(gr)) == as.character(seqnames(ldRef)) & + start(gr) == start(ldRef) if (all(same)) { return(invisible(TRUE)) } nBad <- sum(!same) firstBad <- which(!same)[[1L]] msg <- glue( - "estimateH2: study '{studyName}' and the LD reference disagree at ", + "estimateH2: {what} and the LD reference disagree at ", "{nBad} of {length(same)} position(s), the first at index ", "{firstBad}. The estimators index by the reference's variant ", "order, so both must hold the same variants in the same order." @@ -2573,29 +2543,6 @@ h2EstimateToSldscTrait <- function(h2Est) { .lderLocalBlock(blockStats[[b]], b, N, a) } -# LDER weighted score z for candidate column `cand` under the `keep` block -# mask. -# @noRd -.lderScoreForCand <- function(cand, ldCand, lam, w, resid, N, keep) { - .lderCandidateScore(ldCand[, cand], lam, w, resid, N, keep) -} - -# LDER leave-one-block-out candidate score z's for block `b`. -# @noRd -.lderLooBlockScores <- function(b, blockId, ldCand, lam, w, resid, N, nCand) { - keep <- blockId != b - map_dbl( - seq_len(nCand), - .lderScoreForCand, - ldCand = ldCand, - lam = lam, - w = w, - resid = resid, - N = N, - keep = keep - ) -} - # One g-LDSC delete-one-block jackknife fold: re-solve the normal equations with # block `cb`'s Omega-weighted contribution removed. # @noRd @@ -2611,10 +2558,6 @@ h2EstimateToSldscTrait <- function(h2Est) { # g-LDSC leave-one-block-out standardized candidate score vector for block `b`. # @noRd -.gldscScoreLooRow <- function(b, per, U, I) { - (U - per[[b]]$U) / sqrt(pmax(I - per[[b]]$I, 1e-10)) -} - # One HDL delete-one-block jackknife fold: refit leaving block `b` out. # @noRd .hdlLooFit <- function(b, blockData, M, baselineMat, n, nSamples) { @@ -2633,53 +2576,3 @@ h2EstimateToSldscTrait <- function(h2Est) { .hdlLocalRow <- function(b, blockData, n, nSamples, int, M) { .hdlLocalBlock(blockData[[b]], b, n, nSamples, int, M) } - -# sHDL score z for candidate column `c` under the `keep` block mask. -# @noRd -.shdlScoreForCand <- function( - c, - ldCand, - M_c, - lam, - lamh2, - scoreResid, - nSamples, - keep -) { - .shdlCandidateScore( - ldCand[, c], - M_c[c], - lam, - lamh2, - scoreResid, - nSamples, - keep - ) -} - -# sHDL leave-one-block-out candidate score z's for block `b`. -# @noRd -.shdlLooBlockScores <- function( - b, - blockId, - ldCand, - M_c, - lam, - lamh2, - scoreResid, - nSamples, - nCand -) { - keep <- blockId != b - map_dbl( - seq_len(nCand), - .shdlScoreForCand, - ldCand = ldCand, - M_c = M_c, - lam = lam, - lamh2 = lamh2, - scoreResid = scoreResid, - nSamples = nSamples, - keep = keep - ) -} diff --git a/R/ld.R b/R/ld.R index 99aa904f..9ea55c38 100644 --- a/R/ld.R +++ b/R/ld.R @@ -1175,7 +1175,7 @@ resolveGenotypePathForRegion <- function(metaPath, region) { if (length(tbls) == 0L) { return(NULL) } - af <- list_rbind(tbls) + af <- if (length(tbls) == 1L) tbls[[1L]] else list_rbind(tbls) list( nSamples = as.integer(max(as.numeric(af$obs_ct), na.rm = TRUE) %/% 2), af = select(af, all_of(c("id", "alt_freq"))) @@ -2360,9 +2360,19 @@ resolveGenotypePathForRegion <- function(metaPath, region) { ) } -# Each non-empty row's span, with the row it belongs to. +# Each non-empty row's span, with the row it belongs to. A collection's +# element sits on one (seqname, strand), so its span is one range, read off +# integer vectors (.rtlFirstSpans()) where range() would take minutes on a +# genome-wide collection. # @noRd .rowSpans <- function(x) { + if (methods::is(x, "RangedTupleList")) { + spans <- .rtlFirstSpans(x) + return(list( + spans = .locusRanges(spans$first), + rows = unname(which(spans$has)) + )) + } rr <- range(x) list( spans = .locusRanges(unlist(rr, use.names = FALSE)), diff --git a/R/qtlEnrichmentPipeline.R b/R/qtlEnrichmentPipeline.R index c2903b1c..e100baa7 100644 --- a/R/qtlEnrichmentPipeline.R +++ b/R/qtlEnrichmentPipeline.R @@ -23,11 +23,14 @@ setClass( #' data arguments, \code{BPPARAM}, \code{seed}, \code{verbose}, and the #' \code{alignNames} switch --- is the pipeline's own business and is not #' settable here. -#' @param numGwas Number of GWAS variants used to estimate \code{piGwas}. -#' \code{NULL} (default) estimates it from the data, which is biased unless -#' the outcome PIP vector really is genome-wide. +#' @param numGwas The total number of variants the GWAS tested (fastenloc's +#' \code{-total_variants}), over which \code{piGwas} and \code{piQtl} are +#' estimated. \code{NULL} (default) uses the number of distinct variants in +#' the outcome PIP vector and the annotation fits, with a warning; that is +#' biased unless the outcome PIP vector really is genome-wide. #' @param piQtl Per-variant prior of being a causal QTL variant. \code{NULL} -#' (default) estimates it from the data. +#' (default) estimates it as fastenloc does: the annotation fits' summed +#' PIPs over the variant total (see \code{numGwas}). #' @param lambda Shrinkage parameter, shrinking the enrichment estimate #' towards zero as in ridge regression. \code{0} applies no shrinkage. #' Default \code{1.0}. @@ -122,9 +125,19 @@ QtlEnrichmentParam <- function( #' \code{\link{qtlEnrichment}}, whose multiple-imputation threads number #' its workers. Default \code{SerialParam()}. #' @param seed Integer or \code{NULL}. Base random seed forwarded to -#' \code{\link{qtlEnrichment}} for reproducible multiple imputation. -#' \code{NULL} (default) draws a nondeterministic seed. +#' \code{\link{qtlEnrichment}} for reproducible multiple imputation; every +#' (outcome, annotation) pair is run with this same seed. \code{NULL} +#' (default) draws a nondeterministic seed per pair. #' @param verbose Logical. Print progress messages. Default \code{TRUE}. +#' @param duplicatePips How to resolve a variant to which the outcome's LD +#' blocks give different PIPs, as adjacent blocks sharing a boundary variant +#' do when each block's fit gives it its own. Copies that agree are always +#' merged. \code{"max"} (default) keeps the largest PIP. \code{"blockEnd"} +#' keeps the copy from the block whose window was given (see +#' \code{\link{genomicRegion}}) and ends at the variant --- the upstream of +#' two blocks sharing it --- and errors when no single block qualifies. +#' \code{"error"} refuses. fastenloc does none of these: it keeps the last +#' copy's PIP but counts every copy towards the GWAS prior. #' @return A tibble with one row per (outcome fit, annotation unit) pair. #' The identity columns are \code{gwasStudy}, \code{gwasContext}, #' \code{gwasTrait}, \code{gwasMethod}, \code{qtlStudy}, \code{qtlContext}, @@ -162,21 +175,24 @@ qtlEnrichmentPipeline <- function( qtlEnrichmentParam = QtlEnrichmentParam(), BPPARAM = SerialParam(), seed = NULL, - verbose = TRUE + verbose = TRUE, + duplicatePips = c("max", "error", "blockEnd") ) { .assertMethodParam(qtlEnrichmentParam, "QtlEnrichmentParam") .assertBpparam(BPPARAM) + pipRule <- arg_match(duplicatePips) .enrValidateInputs(gwasFineMappingResult, qtlFineMappingResult) - prep <- .enrPrepare(gwasFineMappingResult, qtlFineMappingResult) + prep <- .enrPrepare( + gwasFineMappingResult, + qtlFineMappingResult, + pipRule + ) gwasTuples <- prep$gwasTuples qtlTuples <- prep$qtlTuples - alignedByTuple <- prep$alignedByTuple results <- list_flatten(map( seq_len(nrow(gwasTuples)), .enrScoreOutcomeTuple, - gwasPipByTuple = prep$gwasPipByTuple, - qtlRegionsByTuple = prep$qtlRegionsByTuple, - alignedByTuple = alignedByTuple, + prep = prep, qtlEnrichmentParam = qtlEnrichmentParam, BPPARAM = BPPARAM, seed = seed, @@ -225,12 +241,18 @@ qtlEnrichmentPipeline <- function( invisible(NULL) } -# Hoist the outcome-independent work out of the double loop: per-trait outcome -# PIP vectors, the union variant-name panel, per-tuple annotation regions, and -# each tuple's one-time alignment to the union panel (errors captured as -# values). +# Hoist the outcome-independent work out of the double loop: each outcome +# tuple's PIPs with its variants, the union of those variants, each annotation +# tuple's regions with theirs, and each tuple's one-time alignment to the union +# (errors captured as values). Variants travel as variant tables +# (.variantTable()) -- chromosome, position, alleles -- and are matched by the +# matching engine, never through rendered id strings. # @noRd -.enrPrepare <- function(gwasFineMappingResult, qtlFineMappingResult) { +.enrPrepare <- function( + gwasFineMappingResult, + qtlFineMappingResult, + duplicatePips = "max" +) { gwasTuples <- .enrOutcomeTuples(gwasFineMappingResult) qtlTuples <- .enrAnnotationTuples(qtlFineMappingResult) if (nrow(gwasTuples) == 0L || nrow(qtlTuples) == 0L) { @@ -245,30 +267,27 @@ qtlEnrichmentPipeline <- function( list(gwasFineMappingResult, qtlFineMappingResult), "qtlEnrichmentPipeline()" ) - gwasPipByTuple <- map( + outcomes <- map( seq_len(nrow(gwasTuples)), - .enrGwasPipForRow, + .enrGwasOutcomeForRow, gwasTuples = gwasTuples, - fmr = gwasFineMappingResult + fmr = gwasFineMappingResult, + duplicatePips = duplicatePips ) - unionGwasNames <- unique(unname(list_c(map(gwasPipByTuple, names)))) - qtlRegionsByTuple <- map( + union <- .enrUnionPanel(outcomes) + annotations <- map( seq_len(nrow(qtlTuples)), - .enrQtlRegionsForRow, + .enrQtlTupleForRow, qtlTuples = qtlTuples, fmr = qtlFineMappingResult ) - alignedByTuple <- map( - qtlRegionsByTuple, - .enrAlignRegionsSafe, - unionGwasNames = unionGwasNames - ) list( gwasTuples = gwasTuples, qtlTuples = qtlTuples, - gwasPipByTuple = gwasPipByTuple, - qtlRegionsByTuple = qtlRegionsByTuple, - alignedByTuple = alignedByTuple + outcomes = outcomes, + union = union, + annotations = annotations, + aligned = map(annotations, .enrAlignTupleSafe, panel = union$table) ) } @@ -340,25 +359,26 @@ qtlEnrichmentPipeline <- function( !is.na(values) & values == wanted } -# The outcome PIP vector for the k-th outcome tuple. +# The outcome PIPs and variants for the k-th outcome tuple. # @noRd -.enrGwasPipForRow <- function(k, gwasTuples, fmr) { - .enrBuildGwasPipVector(fmr, .enrOutcomeIdent(gwasTuples, k)) +.enrGwasOutcomeForRow <- function(k, gwasTuples, fmr, duplicatePips = "max") { + .enrGwasOutcome(fmr, .enrOutcomeIdent(gwasTuples, k), duplicatePips) } -# Annotation SuSiE region list for the k-th (study, context) tuple. +# Annotation regions and variants for the k-th (study, context) tuple. # @noRd -.enrQtlRegionsForRow <- function(k, qtlTuples, fmr) { - .enrBuildQtlRegionsList(fmr, .enrAnnotationIdent(qtlTuples, k)) +.enrQtlTupleForRow <- function(k, qtlTuples, fmr) { + .enrQtlTuple(fmr, .enrAnnotationIdent(qtlTuples, k)) } -# Align one tuple's regions to the union GWAS panel, capturing any error as a -# value (re-raised + skipped per (gwas, tuple) below, never aborting). +# One tuple's variants aligned to the union of the outcome variants: each +# variant's index in the union, or NA. Any error is captured as a value +# (re-raised + skipped per (gwas, tuple) below, never aborting). # @noRd #' @importFrom rlang try_fetch -.enrAlignRegionsSafe <- function(regions, unionGwasNames) { +.enrAlignTupleSafe <- function(annotation, panel) { try_fetch( - .enrAlignRegions(regions, unionGwasNames), + .alignTablesToPanel(annotation$table, panel), error = function(cnd) cnd ) } @@ -368,20 +388,18 @@ qtlEnrichmentPipeline <- function( # @noRd .enrScoreOutcomeTuple <- function( gi, - gwasPipByTuple, - qtlRegionsByTuple, - alignedByTuple = alignedByTuple, + prep, qtlEnrichmentParam, BPPARAM, seed, verbose, - gwasFineMappingResult = gwasFineMappingResult, - gwasTuples = gwasTuples, - qtlFineMappingResult = qtlFineMappingResult, - qtlTuples = qtlTuples + gwasFineMappingResult, + gwasTuples, + qtlFineMappingResult, + qtlTuples ) { - gwasPip <- gwasPipByTuple[[gi]] - if (length(gwasPip) == 0L) { + outcome <- prep$outcomes[[gi]] + if (length(outcome$pip) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable PIPs for ", "{.enrOutcomeLabel(gwasFineMappingResult, gwasTuples, gi)}; ", @@ -390,13 +408,19 @@ qtlEnrichmentPipeline <- function( warn(msg) return(list()) } + # Where each union variant sits in this outcome's PIP vector. + outcomeAt <- replace( + rep(NA_integer_, .variantTableSize(prep$union$table)), + prep$union$of[[gi]], + seq_along(outcome$pip) + ) compact(map( seq_len(nrow(qtlTuples)), .enrScoreTuple, gi = gi, - gwasPip = gwasPip, - qtlRegionsByTuple = qtlRegionsByTuple, - alignedByTuple = alignedByTuple, + outcome = outcome, + outcomeAt = outcomeAt, + prep = prep, qtlEnrichmentParam = qtlEnrichmentParam, BPPARAM = BPPARAM, seed = seed, @@ -409,24 +433,24 @@ qtlEnrichmentPipeline <- function( } # Score one (outcome trait, annotation tuple) pair -> an enrichment record, or -# NULL when the tuple has no regions or qtlEnrichment fails. +# NULL when the tuple has no regions or the enrichment fails. # @noRd .enrScoreTuple <- function( k, gi, - gwasPip, - qtlRegionsByTuple, - alignedByTuple = alignedByTuple, + outcome, + outcomeAt, + prep, qtlEnrichmentParam, BPPARAM, seed, verbose, - gwasFineMappingResult = gwasFineMappingResult, - gwasTuples = gwasTuples, - qtlFineMappingResult = qtlFineMappingResult, - qtlTuples = qtlTuples + gwasFineMappingResult, + gwasTuples, + qtlFineMappingResult, + qtlTuples ) { - if (length(qtlRegionsByTuple[[k]]) == 0L) { + if (length(prep$annotations[[k]]$regions) == 0L) { msg <- glue( "qtlEnrichmentPipeline: no usable regions for ", "{.enrAnnotationLabel(qtlFineMappingResult, qtlTuples, k)}; ", @@ -437,9 +461,10 @@ qtlEnrichmentPipeline <- function( } enr <- .enrRunEnrichment( gi, - gwasPip, + outcome, + outcomeAt, k, - alignedByTuple = alignedByTuple, + prep = prep, qtlEnrichmentParam = qtlEnrichmentParam, BPPARAM = BPPARAM, seed = seed, @@ -477,14 +502,15 @@ qtlEnrichmentPipeline <- function( ) } -# Run qtlEnrichment for a pair (with the pre-aligned regions), warning + NULL on -# failure. +# Run the enrichment for a pair -- the tuple's regions coded against this +# outcome through the precomputed alignment -- warning + NULL on failure. # @noRd .enrRunEnrichment <- function( gi, - gwasPip, + outcome, + outcomeAt, k, - alignedByTuple, + prep, qtlEnrichmentParam, BPPARAM, seed, @@ -494,26 +520,18 @@ qtlEnrichmentPipeline <- function( qtlFineMappingResult, qtlTuples ) { - aligned <- alignedByTuple[[k]] try_fetch( - { - if (inherits(aligned, "condition")) { - cnd_signal(aligned) - } - # alignNames = FALSE reuses the per-tuple alignment; it is the - # pipeline's own invariant, which is why `qtlEnrichmentParam` cannot - # carry it -- QtlEnrichmentParam() has no such formal. - exec( - qtlEnrichment, - gwasPip = gwasPip, - susieQtlRegions = aligned, - BPPARAM = BPPARAM, - seed = seed, - verbose = verbose, - alignNames = FALSE, - !!!qtlEnrichmentParam - ) - }, + .enrFitPair( + prep$aligned[[k]], + prep$annotations[[k]], + outcome, + outcomeAt, + prep$union$table, + qtlEnrichmentParam, + BPPARAM, + seed, + verbose + ), error = function(cnd) { eMsg <- conditionMessage(cnd) msg <- glue( @@ -528,6 +546,45 @@ qtlEnrichmentPipeline <- function( ) } +# The enrichment of one (outcome, annotation tuple) pair: the tuple's regions +# coded against the outcome through the precomputed alignment `aligned` +# (an error from aligning the tuple, kept as a value, is raised here). +# @noRd +.enrFitPair <- function( + aligned, + annotation, + outcome, + outcomeAt, + unionTable, + qtlEnrichmentParam, + BPPARAM, + seed, + verbose +) { + if (inherits(aligned, "condition")) { + cnd_signal(aligned) + } + nullFits <- .enrValidateFits(annotation$regions) + coded <- .enrCodeAligned( + annotation, + outcomeAt[aligned], + aligned, + unionTable + ) + exec( + .qtlEnrichmentCoded, + gwasPip = outcome$pip, + susieQtlRegions = annotation$regions, + coded = coded, + nullFits = nullFits, + gwasVariants = outcome$table, + BPPARAM = BPPARAM, + seed = seed, + verbose = verbose, + !!!qtlEnrichmentParam + ) +} + # Row-bind the enrichment records into the id-first result table. # @noRd .enrAssemble <- function(results) { @@ -572,116 +629,363 @@ qtlEnrichmentPipeline <- function( # Internal helpers # ============================================================================= -# Align one tuple's QTL regions to the GWAS naming convention: relabel matched -# pip names to the union GWAS panel via the shared matcher (unmatched names -# kept as-is). Pure -- the caller precomputes one result per tuple and shares -# it across the outer GWAS loop. +# Align one tuple's QTL regions to the GWAS naming convention: relabel each +# pip name that matches a panel variant to the panel's id, keeping the rest. +# The tuple's names are matched in one pass, not one per region, so the panel +# is read once per tuple however many genes it has. Used by qtlEnrichment(), +# whose interface is named vectors; the pipeline aligns variant tables +# (.alignTablesToPanel()). +#' @importFrom vctrs vec_chop +#' @noRd +.enrAlignRegions <- function( + regions, + panel, + panelTable = .idsVariantTable(panel) +) { + ids <- map(regions, .enrRegionIds) + flat <- as.character(list_c(ids)) + idx <- .alignIdsToPanel(flat, panel, panelTable) + matched <- !is.na(idx) + aligned <- replace(flat, matched, panel[idx[matched]]) + map2(regions, vec_chop(aligned, sizes = lengths(ids)), .enrRenamePip) +} + +# A region with its pip renamed (an unnamed pip has nothing to rename). # @noRd -.enrAlignRegions <- function(regions, unionGwasNames) { - map(regions, .enrAlignRegion, unionGwasNames = unionGwasNames) +.enrRenamePip <- function(x, ids) { + if (is.null(names(x$pip))) { + return(x) + } + list_assign(x, pip = set_names(x$pip, ids)) } -# One row's PIP vector keyed by variant id, or NULL when the row carries no -# fit, no PIPs, or ids that do not line up with them. +# Rows `idx`'s PIPs with their variants, read for all of them at once: +# list(pip, table, row), `row` being each PIP's row of `gwasFmr`. A row that +# carries no fit, no PIPs, or variants that do not line up with them gives +# none. The variants are the names the fit gives its PIPs, else the row's own +# when it holds all of the fit (.fmrRowsFitVariants()). +# @noRd +.enrPipTablesAt <- function(gwasFmr, idx) { + fits <- .fmrFitsAt(gwasFmr, idx) + usable <- which(map_lgl(fits, .enrHasPip)) + vars <- .fmrRowsFitVariants( + gwasFmr, + idx[usable], + fits[usable], + onUnplaced = "skip" + ) + pips <- map(map(fits[usable], "pip"), as.numeric) + n <- vars$n + lined <- !is.na(n) & n == lengths(pips) + held <- rep(lined[!is.na(n)], n[!is.na(n)]) + list( + pip = list_c(pips[lined]), + table = .variantTableRows(vars$table, which(held)), + row = rep(idx[usable][lined], n[lined]) + ) +} + +# @noRd +.enrHasPip <- function(fit) { + is.list(fit) && !is.null(fit$pip) +} + +# One row's PIP vector keyed by variant id (see .enrPipTablesAt()). # @noRd .enrRowPipVector <- function(i, gwasFmr) { - parts <- .fmrRowParts(gwasFmr, i) - fit <- susieFit(parts) - if (is.null(fit) || is.null(fit$pip)) { + piece <- .enrPipTablesAt(gwasFmr, i) + if (length(piece$pip) == 0L) { return(NULL) } - pip <- as.numeric(fit$pip) - ids <- names(fit$pip) %||% .partsFitIds(parts) - if (length(ids) != length(pip)) { - return(NULL) - } - set_names(pip, as.character(ids)) + set_names(piece$pip, .variantTableIds(piece$table)) } -# Build a named outcome PIP vector for one fit. Walks every row of the -# collection carrying that identity -- the fit's LD blocks -- extracts the -# per-row pip from each FineMappingRow, and concatenates with variant-id -# names. Errors if any single variant appears with conflicting PIP values -# across rows -- which is why the identity is the full fit tuple: pooling two -# molecular traits of one study, or two methods' fits of one trait, would -# collide on every variant they share. -#' @importFrom dplyr add_count -#' @noRd -.enrBuildGwasPipVector <- function(gwasFmr, ident) { +# One outcome fit's PIPs and variants: every row of the collection carrying +# that identity -- the fit's LD blocks -- joined. A variant several rows carry +# is resolved by `duplicatePips` -- which is why the identity is the full fit +# tuple: pooling two molecular traits of one study, or two methods' fits of +# one trait, would collide on every variant they share. list(pip, table). +# @noRd +.enrGwasOutcome <- function(gwasFmr, ident, duplicatePips = "max") { idx <- .enrMatchRows(gwasFmr, ident) - if (length(idx) == 0L) { - return(numeric(0)) + pieces <- .enrPipTablesAt(gwasFmr, idx) + if (length(pieces$pip) == 0L) { + return(list( + pip = numeric(0), + table = .variantTableRows(pieces$table, 0L) + )) } - pieces <- compact(map(idx, .enrRowPipVector, gwasFmr = gwasFmr)) - if (length(pieces) == 0L) { + .enrCollapseDuplicateVariants(pieces, duplicatePips, gwasFmr) +} + +# The outcome PIP vector of one fit keyed by variant id (see +# .enrGwasOutcome()). +# @noRd +.enrBuildGwasPipVector <- function(gwasFmr, ident, duplicatePips = "max") { + outcome <- .enrGwasOutcome(gwasFmr, ident, duplicatePips) + if (length(outcome$pip) == 0L) { return(numeric(0)) } - combined <- list_c(pieces) - if (n_distinct(names(combined)) == length(combined)) { - return(combined) + set_names(outcome$pip, .variantTableIds(outcome$table)) +} + +# Collapse variants several GWAS blocks carry, keeping each where it first +# appears. Copies whose PIPs agree (to 12 digits) merge; for a variant whose +# copies conflict, `duplicatePips` decides (see qtlEnrichmentPipeline()). +# A variant is its chromosome, position and alleles as given. +#' @importFrom vctrs vec_group_id vec_unique_loc +#' @noRd +.enrCollapseDuplicateVariants <- function(pieces, duplicatePips, gwasFmr) { + group <- vec_group_id(.variantKeyFrame(pieces$table)) + first <- vec_unique_loc(group) + if (length(first) == length(group)) { + return(list(pip = pieces$pip, table = pieces$table)) + } + collapsed <- list( + pip = pieces$pip[first], + table = .variantTableRows(pieces$table, first) + ) + copies <- .enrConflictingCopies(group, pieces$pip) + if (length(copies) == 0L) { + return(collapsed) } - .enrCollapseDuplicatePips(combined) + resolved <- switch( + duplicatePips, + error = .enrAbortConflictingPips( + .variantTableIds(.variantTableRows(pieces$table, copies[[1L]])) + ), + max = .enrMaxPips(pieces, copies, group), + blockEnd = .enrBlockEndPips(pieces, copies, group, gwasFmr) + ) + # `collapsed` holds each group once, in the order of first appearance, + # which is the order of the group ids. + list_assign( + collapsed, + pip = replace(collapsed$pip, as.integer(names(resolved)), resolved) + ) +} + +# The positions of every copy of each variant whose copies' PIPs conflict +# (differ to 12 digits); `group` is the variant at each position. +#' @importFrom vctrs vec_duplicate_detect +#' @importFrom dplyr filter n_distinct pull +#' @noRd +.enrConflictingCopies <- function(group, pip) { + copied <- which(vec_duplicate_detect(group)) + tibble(at = copied, group = group[copied], pip = round(pip[copied], 12)) |> + filter(n_distinct(.data$pip) > 1L, .by = "group") |> + pull("at") } -# Collapse duplicate variant ids across GWAS blocks: agreeing PIPs (rounded to -# 12 digits) merge; a variant with conflicting PIPs aborts. distinct() keeps one -# row per (id, rounded-pip), so a conflicting variant survives with >1 row for -# add_count() to flag. # @noRd -.enrCollapseDuplicatePips <- function(pips) { - byId <- tibble(id = names(pips), pip = as.numeric(pips)) |> - mutate(pipR = round(.data$pip, 12)) |> - distinct(.data$id, .data$pipR, .keep_all = TRUE) |> - add_count(.data$id) - conflict <- filter(byId, .data$n > 1L) - if (nrow(conflict) > 0L) { - vName <- conflict$id[[1L]] - msg <- glue( - "qtlEnrichmentPipeline: variant '{vName}' appears with ", - "conflicting PIPs across GWAS blocks; the GWAS fine-mapping ", - "must produce a consistent PIP per variant." - ) - abort(msg) +.enrAbortConflictingPips <- function(id) { + msg <- glue( + "qtlEnrichmentPipeline: variant '{id}' appears with conflicting PIPs ", + "across GWAS blocks; the GWAS fine-mapping must produce a consistent ", + "PIP per variant, or pass duplicatePips = \"max\" or \"blockEnd\"." + ) + abort(msg) +} + +# The largest PIP of each conflicting variant, named by its group. +#' @importFrom dplyr summarise +#' @noRd +.enrMaxPips <- function(pieces, copies, group) { + best <- tibble(group = group[copies], pip = pieces$pip[copies]) |> + summarise(pip = max(.data$pip), .by = "group") + set_names(best$pip, best$group) +} + +# The PIP of each conflicting variant's copy from the one block whose given +# window ends at the variant, named by its group; a variant with no such +# block, or several, aborts. +#' @importFrom GenomicRanges end seqnames +#' @noRd +.enrBlockEndPips <- function(pieces, copies, group, gwasFmr) { + rows <- pieces$row[copies] + windows <- genomicRegion(gwasFmr)[rows] + given <- as.logical(.tupleColumn(gwasFmr, "regionGiven"))[rows] + atEnd <- !is.na(given) & + given & + as.character(seqnames(windows)) == pieces$table$chrom[copies] & + end(windows) == pieces$table$pos[copies] + undecided <- tibble(group = group[copies], atEnd = atEnd) |> + summarise(nAtEnd = sum(.data$atEnd), .by = "group") |> + filter(.data$nAtEnd != 1L) |> + arrange(.data$group) + if (nrow(undecided) > 0L) { + .enrAbortUndecidedBlockEnd(pieces, copies, group, undecided) } - set_names(byId$pip, byId$id) + set_names(pieces$pip[copies][atEnd], group[copies][atEnd]) } -# Build the per-(study, context) list of region fits in the shape that -# qtlEnrichment expects: list(d) where each d carries alpha, pip, -# prior_variance (V). Filters on BOTH study and context so entries from -# different studies that happen to share a context label are not pooled into -# one enrichment estimate. +# The first variant `undecided` lists (its group and how many of its blocks' +# windows end at it), refused for duplicatePips = "blockEnd". +# @noRd +.enrAbortUndecidedBlockEnd <- function(pieces, copies, group, undecided) { + first <- copies[group[copies] == undecided$group[[1L]]][[1L]] + id <- .variantTableIds(.variantTableRows(pieces$table, first)) + msg <- glue( + "qtlEnrichmentPipeline: variant '{id}' appears with ", + "conflicting PIPs across GWAS blocks, and duplicatePips = ", + "\"blockEnd\" cannot choose between them: ", + "{undecided$nAtEnd[[1L]]} of its blocks were given a window ", + "ending at it, where one must be." + ) + abort(msg) +} + +# The union of the outcome tuples' variants, and each tuple's variants' index +# in it: list(table, of). +#' @importFrom vctrs vec_match vec_unique_loc +#' @noRd +.enrUnionPanel <- function(outcomes) { + tables <- map(outcomes, "table") + if (length(tables) == 1L) { + n <- .variantTableSize(tables[[1L]]) + return(list(table = tables[[1L]], of = list(seq_len(n)))) + } + joined <- .bindVariantTables(tables) + union <- .variantTableRows(joined, vec_unique_loc(.variantKeyFrame(joined))) + list( + table = union, + of = map(tables, .enrUnionIndex, unionFrame = .variantKeyFrame(union)) + ) +} + +# Each variant of `table`'s index in the union's key frame `unionFrame`. +# @noRd +.enrUnionIndex <- function(table, unionFrame) { + vec_match(.variantKeyFrame(table), unionFrame) +} + +# One annotation tuple's region fits for qtlEnrichment -- alpha, pip and the +# prior variances -- and their variants as one variant table, region after +# region: list(regions, table, n). Filters on BOTH study and context so +# entries from different studies that happen to share a context label are not +# pooled into one enrichment estimate. Regions are named by their rows' own +# names ("study|context|trait|method"), so a fit the estimator refuses is +# reported by name rather than position. +# @noRd +.enrQtlTuple <- function(qtlFmr, ident) { + idx <- .enrMatchRows(qtlFmr, ident) + fits <- .fmrFitsAt(qtlFmr, idx) + usable <- which(map_lgl(fits, .enrHasRegion)) + vars <- .fmrRowsFitVariants( + qtlFmr, + idx[usable], + fits[usable], + onUnplaced = "error" + ) + list( + regions = set_names( + map(fits[usable], .enrRegionOf), + names(qtlFmr)[idx[usable]] + ), + table = vars$table, + n = vars$n + ) +} + +# Rows `idx`'s region payloads for qtlEnrichment with their PIPs named by +# variant id; NULL for a row that lacks a fit, an alpha, PIPs, or a prior +# variance (see .enrQtlTuple()). +# @noRd +.enrRegionsAt <- function(qtlFmr, idx) { + fits <- .fmrFitsAt(qtlFmr, idx) + usable <- which(map_lgl(fits, .enrHasRegion)) + if (length(usable) == 0L) { + return(vector("list", length(idx))) + } + vars <- .fmrRowsFitVariants( + qtlFmr, + idx[usable], + fits[usable], + onUnplaced = "error" + ) + regions <- map2( + map(fits[usable], .enrRegionOf), + vec_chop(.variantTableIds(vars$table), sizes = vars$n), + .enrNamedRegion + ) + replace(vector("list", length(idx)), usable, regions) +} + +# A region payload with its PIPs named by `ids`. +# @noRd +.enrNamedRegion <- function(region, ids) { + list_assign(region, pip = set_names(region$pip, ids)) +} + +# One row's region payload for qtlEnrichment (see .enrRegionsAt()). +# @noRd +.enrRowRegion <- function(i, qtlFmr) { + .enrRegionsAt(qtlFmr, i)[[1L]] +} + +# The per-(study, context) list of region fits with named PIPs, as +# qtlEnrichment() takes them (see .enrQtlTuple()). # @noRd .enrBuildQtlRegionsList <- function(qtlFmr, ident) { idx <- .enrMatchRows(qtlFmr, ident) if (length(idx) == 0L) { return(list()) } - compact(map(idx, .enrRowRegion, qtlFmr = qtlFmr)) + compact(set_names(.enrRegionsAt(qtlFmr, idx), names(qtlFmr)[idx])) } -# One row's region payload for qtlEnrichment, or NULL when the row lacks a -# fit, an alpha, PIPs, or a prior variance. The PIP names fall back to the -# ids the fit was made with when the fit did not carry any. +# Whether `fit` carries what a region payload needs. # @noRd -.enrRowRegion <- function(i, qtlFmr) { - parts <- .fmrRowParts(qtlFmr, i) - fit <- susieFit(parts) - if (is.null(fit) || is.null(fit$alpha) || is.null(fit$pip)) { - return(NULL) - } - priorVariance <- fit$V %||% fit$prior_variance - if (is.null(priorVariance)) { - return(NULL) - } +.enrHasRegion <- function(fit) { + is.list(fit) && + !is.null(fit$alpha) && + !is.null(fit$pip) && + !is.null(fit$V %||% fit$prior_variance) +} + +# @noRd +.enrRegionOf <- function(fit) { list( alpha = fit$alpha, - pip = set_names( - fit$pip, - names(fit$pip) %||% .partsFitIds(parts) + pip = fit$pip, + prior_variance = fit$V %||% fit$prior_variance + ) +} + +# An annotation tuple coded against one outcome: each region variable's +# 0-based index in the outcome's PIP vector (`outcomeIdx`, through the union +# alignment `unionIdx`), or a negative id shared by every region carrying the +# same absent variant -- the union's variant where the union holds it, else +# the tuple's own. Coded as .enrCodeRegions() codes names. +#' @importFrom vctrs vec_group_id +#' @noRd +.enrCodeAligned <- function(annotation, outcomeIdx, unionIdx, unionTable) { + absent <- which(is.na(outcomeIdx)) + group <- .enrAbsentGroups(annotation$table, absent, unionIdx, unionTable) + codes <- replace(outcomeIdx - 1L, absent, -as.vector(group)) + list( + fits = map2( + annotation$regions, + vec_chop(codes, sizes = annotation$n), + .enrCodedFit ), - prior_variance = priorVariance + unmatched = NULL, + nQtlOnly = attr(group, "n") + ) +} + +# The group id (vctrs) of each of the tuple's variables `absent` from the +# outcome: one per distinct variant -- the union's variant where the union +# holds it, else the tuple's own. +# @noRd +.enrAbsentGroups <- function(table, absent, unionIdx, unionTable) { + inUnion <- !is.na(unionIdx[absent]) + key <- .variantTableWithRows( + .variantTableRows(table, absent), + which(inUnion), + .variantTableRows(unionTable, unionIdx[absent][inUnion]) ) + vec_group_id(.variantKeyFrame(key)) } # Pull one enrichment field from qtlEnrichment's list output as a scalar numeric @@ -783,16 +1087,33 @@ qtlEnrichmentPipeline <- function( #' @details Uses output of \code{\link[susieR]{susie}} from the \code{susieR} #' package. #' -#' @param gwasPip This is a vector of GWAS PIP, genome-wide. -#' @param susieQtlRegions This is a list of SuSiE fitted objects per QTL unit -#' analyzed -#' @param numGwas This parameter is highly important if GWAS input does not -#' contain all SNPs interrogated (e.g., in some cases, only fine-mapped geomic -#' regions are included). Then users must pick a value of total_variants and -#' estimate piGwas beforehand by: sum(gwasPip$pip)/numGwas. If numGwas is -#' null, piGwas would be sum(gwasPip$pip)/total_variants. -#' @param piQtl This parameter can be safely left to default if your input QTL -#' data has enough regions to estimate it. +#' As in fastenloc, the variants the estimate is taken over are every +#' variant of \code{gwasPip} plus every QTL variant \code{gwasPip} does not +#' carry. The latter have GWAS PIP 0, so each one sampled in an imputation +#' round counts as a QTL variant that is not causal for the GWAS trait. The +#' variant total is \code{numGwas}, raised to the number of those variants +#' when smaller; \code{piGwas} is \code{sum(gwasPip)} over it and, unless +#' supplied, \code{piQtl} is the fits' summed PIPs over it. The intercept is +#' derived from \code{piGwas}, \code{piQtl} and the unshrunk enrichment, +#' and the coloc priors from that intercept and the shrunk enrichment, both +#' as fastenloc does. One difference remains: fastenloc's EM keeps the +#' previous iteration's intercept at convergence where this one updates it, +#' which changes only \code{sd (intercept)}. +#' +#' @param gwasPip A named vector of GWAS PIPs, one per variant, ideally +#' genome-wide. +#' @param susieQtlRegions A named list of SuSiE fits, one per QTL unit +#' analyzed (e.g. a gene), each with \code{alpha}, a named \code{pip} and +#' \code{prior_variance}. +#' @param numGwas The total number of variants the GWAS tested (fastenloc's +#' \code{-total_variants}). It matters whenever \code{gwasPip} does not +#' carry every variant tested, e.g. when it covers only fine-mapped blocks. +#' \code{NULL} (default) uses the number of distinct variants in +#' \code{gwasPip} and the QTL fits, with a warning; a value below that number +#' is raised to it. +#' @param piQtl Per-variant prior of being a causal QTL variant. \code{NULL} +#' (default) estimates it as fastenloc does, from the fits' summed PIPs over +#' the variant total. #' @param lambda Similar to the shrinkage parameter used in ridge regression. It #' takes any non-negative value and shrinks the enrichment estimate towards 0. #' When it is set to 0, no shrinkage will be applied. A large value indicates @@ -802,12 +1123,13 @@ qtlEnrichmentPipeline <- function( #' the multiple imputation runs on when they run on this machine #' (\code{SerialParam}, \code{MulticoreParam}); any other backend gives one #' thread. Default \code{SerialParam()}. -#' @param alignNames Logical; when TRUE (default) QTL pip names are aligned to -#' the GWAS variant-naming convention via \code{matchVariants}. Set FALSE when -#' the caller has already aligned them (e.g. \code{qtlEnrichmentPipeline} -#' aligns each QTL tuple once against the union GWAS panel rather than -#' re-aligning per GWAS study); only the cheap per-study unmatched set is then -#' recomputed, skipping the costly \code{harmonizeAlleles} pass. +#' @param alignNames Logical; when TRUE (default) a QTL pip name not spelled +#' as any \code{gwasPip} name is matched, allele-aware (id format, ref/alt +#' swap, strand), to the GWAS variants at its position, and takes the name +#' of the one it matches. Set FALSE when the caller has already aligned them +#' (e.g. \code{qtlEnrichmentPipeline} aligns each QTL tuple once against +#' the union GWAS panel rather than re-aligning per GWAS study); the names +#' are then matched to \code{gwasPip} exactly as given. #' @param doubleShrinkage Logical. Apply the double-shrinkage correction to the #' enrichment estimate. Default \code{FALSE}. #' @param besselCorrection Logical. Apply Bessel's correction when estimating @@ -822,42 +1144,48 @@ qtlEnrichmentPipeline <- function( #' \code{sd (intercept)}, \code{Enrichment (no shrinkage)}, #' \code{Enrichment (w/ shrinkage)}, \code{sd (no shrinkage)}, #' \code{sd (w/ shrinkage)}, \code{Alternative (coloc) p1} / \code{p2} / -#' \code{p12} and \code{Effective MI rounds} -- plus -#' \code{unused_xqtl_variants}, the QTL variants of each region that no GWAS -#' variant matched. The names are the original fastenloc's; -#' \code{\link{qtlEnrichmentPipeline}} is what renames them to a tidy table. +#' \code{p12} and \code{Effective MI rounds} -- plus diagnostics: +#' \code{Missing proportion per MI round}, the share of each round's sampled +#' QTL variants that \code{gwasPip} does not carry (they enter with GWAS +#' PIP 0); +#' \code{EM converged per MI round}; \code{EM iterations per MI round}, +#' how many EM iterations each round took; \code{Null QTL fits}, the number of +#' fits with no effect of positive prior variance, which contribute no +#' sampled variants; and \code{unused_xqtl_variants}, the QTL variants of +#' each region that no GWAS variant matched. The estimate names are the +#' original fastenloc's; \code{\link{qtlEnrichmentPipeline}} is what renames +#' them to a tidy table. #' #' @examples -#' -#' # Simulate fake data for gwasPip -#' nGwasPip <- 1000 -#' gwasPip <- runif(nGwasPip) -#' names(gwasPip) <- paste0("snp", 1:nGwasPip) -#' # Simulate fake data for a single SuSiEFit object -#' simulateSusiefit <- function(n, p) { -#' pip <- runif(n) -#' names(pip) <- paste0("snp", 1:n) -#' alpha <- t(matrix(runif(n * p), nrow = n)) -#' alpha <- t(apply(alpha, 1, function(row) row / sum(row))) +#' set.seed(1) +#' # GWAS PIPs for 2000 variants of a GWAS that tested one million: mostly +#' # near zero, with two strong signals. +#' ids <- sprintf("chr1:%d:A:G", 1000 * seq_len(2000)) +#' gwasPip <- stats::setNames(stats::rbeta(2000, 0.05, 100), ids) +#' gwasPip[c(300, 1200)] <- c(0.95, 0.6) +#' # A SuSiE-like fit per gene: two single effects over the gene's variants, +#' # each concentrated on a few of them. +#' simulateFit <- function(idx, hits) { +#' alpha <- matrix(1e-4, length(hits), length(idx)) +#' alpha[cbind(seq_along(hits), hits)] <- 1 +#' alpha <- alpha / rowSums(alpha) #' list( -#' pip = pip, #' alpha = alpha, -#' prior_variance = runif(p) +#' pip = stats::setNames(1 - apply(1 - alpha, 2, prod), ids[idx]), +#' prior_variance = c(0.4, 0.1) #' ) #' } -#' # Simulate multiple SuSiEFit objects -#' nSusieFits <- 2 -#' susieFits <- replicate( -#' nSusieFits, simulateSusiefit(nGwasPip, 10), simplify = FALSE) -#' # Add these fits to a list, providing names to each element -#' names(susieFits) <- paste0("fit", seq_along(susieFits)) -#' # Set other parameters -#' impN <- 10 -#' lambda <- 1 -#' library(pecotmr) +#' susieFits <- list( +#' gene1 = simulateFit(251:350, c(50, 10)), +#' gene2 = simulateFit(1151:1250, c(50, 80)), +#' gene3 = simulateFit(1601:1700, c(20, 70)) +#' ) #' en <- qtlEnrichment( -#' gwasPip, susieFits, lambda = lambda, impN = impN, -#' BPPARAM = BiocParallel::SerialParam()) +#' gwasPip, susieFits, +#' numGwas = 1e6, impN = 10, seed = 1, +#' BPPARAM = BiocParallel::SerialParam(), verbose = FALSE +#' ) +#' en[["Enrichment (w/ shrinkage)"]] #' #' @seealso \code{\link[susieR]{susie}} #' @useDynLib pecotmr, .registration = TRUE @@ -878,20 +1206,66 @@ qtlEnrichment <- function( seed = NULL ) { .assertBpparam(BPPARAM) - piGwas <- .enrEstimatePiGwas(gwasPip, numGwas, verbose) - piQtl <- .enrEstimatePiQtl(susieQtlRegions, piQtl, verbose) - .enrValidatePi(piGwas, piQtl) .enrValidateNames(gwasPip, susieQtlRegions) - # Align each region's pip names to the GWAS convention + record unmatched. + nullFits <- .enrValidateFits(susieQtlRegions) + # Relabel each region's pip names to the GWAS convention, then code every + # variable against the GWAS vector, so the kernel works on indices. aligned <- .enrAlignPipNames(susieQtlRegions, gwasPip, alignNames) - unmatchedVariants <- map(aligned, "unmatched_variants") - susieQtlRegions <- map(aligned, .enrStripUnmatched) + .qtlEnrichmentCoded( + gwasPip = gwasPip, + susieQtlRegions = susieQtlRegions, + coded = .enrCodeRegions(aligned, names(gwasPip)), + nullFits = nullFits, + numGwas = numGwas, + piQtl = piQtl, + lambda = lambda, + impN = impN, + doubleShrinkage = doubleShrinkage, + besselCorrection = besselCorrection, + BPPARAM = BPPARAM, + verbose = verbose, + seed = seed + ) +} + +# The estimate from regions already coded against the GWAS PIP vector +# (`coded`: the kernel-ready fits, the number of distinct QTL-only variants +# and each region's unmatched ids). Shared by qtlEnrichment(), which codes +# by name, and qtlEnrichmentPipeline(), which codes by variant +# (.enrCodeAligned()); `gwasVariants`, the PIPs' variants, is the +# pipeline's and only informs. +# @noRd +.qtlEnrichmentCoded <- function( + gwasPip, + susieQtlRegions, + coded, + nullFits, + numGwas = NULL, + piQtl = NULL, + lambda = 1.0, + impN = 25, + doubleShrinkage = FALSE, + besselCorrection = TRUE, + BPPARAM = SerialParam(), + verbose = TRUE, + seed = NULL, + gwasVariants = NULL +) { + priors <- .enrPriors( + gwasPip, + susieQtlRegions, + coded$nQtlOnly, + numGwas, + piQtl, + verbose + ) # cpp11 requires exact integer types for int parameters. en <- qtlEnrichmentCpp( - rGwasPip = gwasPip, - rQtlSusieFit = susieQtlRegions, - piGwas = piGwas, - piQtl = piQtl, + rGwasPip = as.numeric(gwasPip), + rQtlSusieFit = coded$fits, + piGwas = priors$piGwas, + piQtl = priors$piQtl, + totalVariants = priors$totalVariants, ImpN = as.integer(impN), shrinkageLambda = lambda, doubleShrinkage = doubleShrinkage, @@ -899,73 +1273,143 @@ qtlEnrichment <- function( numThreads = .bpLocalThreads(BPPARAM, "qtlEnrichment"), seed = if (is.null(seed)) NULL else as.integer(seed) ) - list_assign(en, unused_xqtl_variants = unmatchedVariants) + .enrCheckRounds(en) + .enrReportDiagnostics(en, nullFits, length(susieQtlRegions), verbose) + list_assign( + en, + `Invalid MI rounds` = zap(), + `Null QTL fits` = nullFits, + unused_xqtl_variants = coded$unmatched + ) } -# piGwas = sum(gwasPip) / numGwas (estimated from the data, with a warning, when -# numGwas is absent). +# The variant total and the two priors the enrichment is taken over, checked. +# As in fastenloc, the variant universe is every GWAS variant plus every QTL +# variant the GWAS vector does not carry (`nQtlOnly` of them), which has GWAS +# PIP 0. # @noRd -.enrEstimatePiGwas <- function(gwasPip, numGwas, verbose) { - if (!is.null(numGwas)) { - return(sum(gwasPip) / numGwas) +.enrPriors <- function( + gwasPip, + susieQtlRegions, + nQtlOnly, + numGwas, + piQtl, + verbose +) { + totalVariants <- .enrTotalVariants(numGwas, length(gwasPip) + nQtlOnly) + piGwas <- .enrEstimatePiGwas(gwasPip, totalVariants, numGwas, verbose) + qtlPrior <- .enrEstimatePiQtl( + susieQtlRegions, + piQtl, + totalVariants, + verbose + ) + .enrValidatePi(piGwas, qtlPrior) + list(totalVariants = totalVariants, piGwas = piGwas, piQtl = qtlPrior) +} + +# The variant total both priors are taken over: fastenloc's -total_variants, +# which may not fall below the number of distinct variants the data carry (the +# GWAS PIP vector plus the QTL variants it lacks). Without numGwas that number +# is used, with a warning, since a GWAS PIP vector covering only fine-mapped +# blocks makes it far smaller than the variants the GWAS tested. +#' @importFrom checkmate assertNumber +#' @noRd +.enrTotalVariants <- function(numGwas, universe) { + if (is.null(numGwas)) { + warn(glue( + "numGwas is not provided. Using the {universe} distinct variants ", + "of gwasPip and the QTL fits as the variant total, which biases ", + "piGwas and piQtl upward unless gwasPip is genome-wide. fastenloc ", + "requires this total as -total_variants." + )) + return(universe) } - warn(glue( - "numGwas is not provided. Estimating piGwas from the data. Note ", - "that this estimate may be biased if the input gwasPip does not ", - "contain genome-wide variants." - )) - piGwas <- sum(gwasPip) / length(gwasPip) - if (verbose) { + assertNumber(numGwas, lower = 1, finite = TRUE) + if (numGwas < universe) { + warn(glue( + "numGwas ({numGwas}) is smaller than the {universe} distinct ", + "variants of gwasPip and the QTL fits; using {universe}, as ", + "fastenloc does." + )) + return(universe) + } + numGwas +} + +# piGwas = sum(gwasPip) / the variant total (reported when the total was +# estimated). +# @noRd +.enrEstimatePiGwas <- function(gwasPip, totalVariants, numGwas, verbose) { + piGwas <- sum(gwasPip) / totalVariants + if (is.null(numGwas) && verbose) { piGwasR <- round(piGwas, 5) inform(glue("Estimated piGwas: {piGwasR}\n", .trim = FALSE)) } piGwas } -# piQtl = total signal / total variants across regions (estimated, with a -# warning, when piQtl is absent). +# piQtl = the QTL fits' summed PIPs / the variant total, as in fastenloc +# (estimated, with a warning, when piQtl is absent). # @noRd -.enrEstimatePiQtl <- function(susieQtlRegions, piQtl, verbose) { +.enrEstimatePiQtl <- function(susieQtlRegions, piQtl, totalVariants, verbose) { if (!is.null(piQtl)) { return(piQtl) } msg <- glue( - "piQtl is not provided. Estimating piQtl from the data. Note that ", - "this estimate may be biased if either 1) the input susieQtlRegions ", - "does not have enough data, or 2) the single effects only include ", - "variables inside of credible sets or signal clusters." + "piQtl is not provided. Estimating piQtl as the QTL fits' summed PIPs ", + "over the variant total. Note that this estimate may be biased if ", + "either 1) the variant total is not the number of variants tested ", + "(see numGwas), or 2) the single effects only include variables ", + "inside of credible sets or signal clusters." ) warn(msg) - allPips <- list_c(map(susieQtlRegions, "pip")) - piQtl <- sum(allPips) / length(allPips) + estimate <- sum(map_dbl(susieQtlRegions, .enrPipSum)) / totalVariants if (verbose) { - piQtlR <- round(piQtl, 5) + piQtlR <- round(estimate, 5) inform(glue("Estimated piQtl: {piQtlR}\n", .trim = FALSE)) } - piQtl + estimate +} + +# @noRd +.enrPipSum <- function(x) { + sum(x$pip) } -# Neither prior probability may be zero. +# Each prior probability must lie in (0, 1), and so must their sum: the EM's +# starting cells and its intercept are only defined then. # @noRd .enrValidatePi <- function(piGwas, piQtl) { - if (piGwas == 0) { + if (!(piGwas > 0)) { msg <- glue( "Cannot perform enrichment analysis. No association signal found ", "in GWAS data." ) abort(msg) } - if (piQtl == 0) { + if (!(piQtl > 0)) { msg <- glue( "Cannot perform enrichment analysis. No QTL associated with the ", "molecular phenotype." ) abort(msg) } + if (!(piGwas + piQtl < 1)) { + piGwasR <- signif(piGwas, 3) + piQtlR <- signif(piQtl, 3) + msg <- glue( + "qtlEnrichment: piGwas ({piGwasR}) and piQtl ({piQtlR}) must sum ", + "to less than 1. Supply numGwas, the total number of variants ", + "the GWAS tested." + ) + abort(msg) + } invisible(NULL) } -# Both gwasPip and every region's pip must carry variant names. +# Both gwasPip and every region's pip must carry variant names, and gwasPip +# one PIP per variant: the variant total counts its names. # @noRd .enrValidateNames <- function(gwasPip, susieQtlRegions) { if (is.null(names(gwasPip))) { @@ -975,6 +1419,14 @@ qtlEnrichment <- function( ) abort(msg) } + dup <- anyDuplicated(names(gwasPip)) + if (dup > 0L) { + msg <- glue( + "gwasPip names variant '{names(gwasPip)[[dup]]}' more than once; ", + "give each variant one PIP." + ) + abort(msg) + } if (!all(map_lgl(susieQtlRegions, .enrHasPipNames))) { msg <- glue( "Variant names are missing in susieQtlRegions$pip. Please provide ", @@ -991,64 +1443,199 @@ qtlEnrichment <- function( !is.null(names(x$pip)) } -# Align each region's pip names to gwasPip (relabel + record unmatched), or -- -# when the caller already aligned (alignNames = FALSE) -- only recompute the -# cheap per-study unmatched set. +# Every region fit must be one the kernel can sample from: alpha a finite, +# non-negative matrix with a column per pip variant and a row per prior +# variance, and each effect of positive prior variance a distribution (its row +# sums to 1). A malformed fit used to read out of bounds in the kernel (a +# null_weight fit has one more alpha column than variants) or slip NaN past its +# row-sum check, so it is refused here, by name. A fit with no effect of +# positive prior variance is a null fit: it samples nothing, but a tuple made +# only of null fits has nothing to estimate from. Returns the null-fit count. # @noRd -.enrAlignPipNames <- function(susieQtlRegions, gwasPip, alignNames) { - if (alignNames) { - return(map(susieQtlRegions, .enrAlignRegionByMatch, gwasPip = gwasPip)) +.enrValidateFits <- function(susieQtlRegions) { + problems <- compact(imap(susieQtlRegions, .enrFitProblem)) + if (length(problems) > 0L) { + abort(c( + "qtlEnrichment: malformed QTL fit(s):", + set_names(utils::head(map_chr(problems, as.character), 5L), "x") + )) + } + nullFit <- map_lgl(susieQtlRegions, .enrIsNullFit) + if (length(nullFit) > 0L && all(nullFit)) { + abort(glue( + "qtlEnrichment: none of the {length(nullFit)} QTL fits has an ", + "effect with prior variance > 0, so there is nothing to sample." + )) } - map(susieQtlRegions, .enrMarkUnmatched, gwasNameSet = names(gwasPip)) + sum(nullFit) } -# Relabel a region's matched pip names to the GWAS convention via the shared -# matcher, recording the unmatched variant names. +# The first problem with one region fit, or NULL. # @noRd -.enrAlignRegionByMatch <- function(x, gwasPip) { - mm <- matchVariants(names(x$pip), names(gwasPip)) - nm <- replace(names(x$pip), mm$idxA, names(gwasPip)[mm$idxB]) - aligned <- list_assign(x, pip = set_names(x$pip, nm)) - unmatchedIdx <- setdiff(seq_along(aligned$pip), mm$idxA) - list_assign( - aligned, - !!!compact(list( - unmatched_variants = if (length(unmatchedIdx) > 0) { - names(aligned$pip)[unmatchedIdx] - } +.enrFitProblem <- function(x, label) { + alpha <- x$alpha + priorVariance <- x$prior_variance + if (!is.matrix(alpha) || !is.numeric(alpha)) { + return(glue("{label}: alpha is not a numeric matrix")) + } + if (ncol(alpha) != length(x$pip)) { + return(glue( + "{label}: alpha has {ncol(alpha)} columns for {length(x$pip)} ", + "pip variants" )) + } + if (nrow(alpha) != length(priorVariance)) { + return(glue( + "{label}: alpha has {nrow(alpha)} rows for ", + "{length(priorVariance)} prior variances" + )) + } + if (!all(is.finite(priorVariance))) { + return(glue("{label}: prior variances must be finite")) + } + if (!all(is.finite(alpha)) || any(alpha < 0)) { + return(glue("{label}: alpha must be finite and non-negative")) + } + rowDev <- abs(rowSums(alpha[priorVariance > 0, , drop = FALSE]) - 1) + if (any(rowDev > 1e-6)) { + return(glue( + "{label}: an alpha row of positive prior variance does not sum ", + "to 1" + )) + } + NULL +} + +# TRUE when no effect of the fit has positive prior variance. +# @noRd +.enrIsNullFit <- function(x) { + !any(x$prior_variance > 0) +} + +# Relabel each region's pip names to the GWAS convention, unless the caller +# already did (alignNames = FALSE). +# @noRd +.enrAlignPipNames <- function(susieQtlRegions, gwasPip, alignNames) { + if (!alignNames) { + return(susieQtlRegions) + } + .enrAlignRegions(susieQtlRegions, names(gwasPip)) +} + +# Code every region's variables against the GWAS names in one pass: the +# 0-based index of the same variant in the GWAS PIP vector, or a negative id +# shared by every region carrying the same absent variant. One match() over the +# concatenated names hashes the GWAS panel once, where a lookup per region +# would rehash it for every gene. Also returns each region's absent names and +# the number of distinct absent variants. +# @noRd +.enrCodeRegions <- function(regions, gwasNames) { + ids <- map(regions, .enrRegionIds) + flat <- as.character(list_c(ids)) + idx <- match(flat, gwasNames) + absent <- is.na(idx) + qtlOnly <- unique(flat[absent]) + codes <- if_else(absent, -match(flat, qtlOnly), idx - 1L) + sizes <- lengths(ids) + unmatched <- map2( + vec_chop(flat, sizes = sizes), + vec_chop(absent, sizes = sizes), + .enrAbsentNames + ) + list( + fits = map2(regions, vec_chop(codes, sizes = sizes), .enrCodedFit), + unmatched = set_names(unmatched, names(regions)), + nQtlOnly = length(qtlOnly) ) } -# Record the region's variants absent from the GWAS name set (cheap membership -# test; names already aligned by the caller). +# A region's variable names `ids` the GWAS lacks (`absent`), or NULL for none. # @noRd -.enrMarkUnmatched <- function(x, gwasNameSet) { - unmatchedIdx <- which(!is_in(names(x$pip), gwasNameSet)) - list_assign( - x, - !!!compact(list( - unmatched_variants = if (length(unmatchedIdx) > 0) { - names(x$pip)[unmatchedIdx] - } - )) +.enrAbsentNames <- function(ids, absent) { + .enrNullIfEmpty(ids[absent]) +} + +# @noRd +.enrRegionIds <- function(x) { + names(x$pip) +} + +# @noRd +.enrNullIfEmpty <- function(x) { + if (length(x) == 0L) NULL else x +} + +# One region in the form the kernel reads: alpha (double), prior variances +# and the variables' integer codes. +# @noRd +.enrCodedFit <- function(x, codes) { + list( + alpha = if (is.double(x$alpha)) { + x$alpha + } else { + `storage.mode<-`(x$alpha, value = "double") + }, + prior_variance = as.numeric(x$prior_variance), + codes = as.integer(codes) ) } -# Drop the transient unmatched_variants field from a region. +# A round whose (not QTL, not causal) EM cell came out non-positive had a +# variant total too small for its data; its estimates are NaN. # @noRd -.enrStripUnmatched <- function(x) { - list_modify(x, unmatched_variants = zap()) +.enrCheckRounds <- function(en) { + invalid <- en[["Invalid MI rounds"]] + if (invalid > 0L) { + nRounds <- length(en[["EM converged per MI round"]]) + msg <- glue( + "qtlEnrichment: the variant total is too small for the data in ", + "{invalid} of {nRounds} MI round(s), leaving the EM no variants ", + "that are neither QTL nor causal. Supply numGwas, the total ", + "number of variants the GWAS tested." + ) + abort(msg) + } + invisible(NULL) } -# Relabel one region's matched pip names to the union GWAS panel (unmatched -# names kept as-is). +# The kernel no longer prints from its worker threads; its per-round +# diagnostics come back and are reported here. A round whose EM ran out of +# iterations is always worth a warning; the rest is progress, shown only when +# verbose. # @noRd -.enrAlignRegion <- function(x, unionGwasNames) { - if (!is.null(names(x$pip)) && length(unionGwasNames) > 0L) { - mm <- matchVariants(names(x$pip), unionGwasNames) - nm <- replace(names(x$pip), mm$idxA, unionGwasNames[mm$idxB]) - return(list_assign(x, pip = set_names(x$pip, nm))) +.enrReportDiagnostics <- function(en, nullFits, nFits, verbose) { + converged <- en[["EM converged per MI round"]] + if (!all(converged)) { + warn(glue( + "qtlEnrichment: the EM did not converge within 1000 iterations ", + "in {sum(!converged)} of {length(converged)} MI round(s)." + )) + } + if (!verbose) { + return(invisible(NULL)) } - x + if (nullFits > 0L) { + inform(glue( + "{nullFits} of {nFits} QTL fits have no effect with prior ", + "variance > 0 and contribute no sampled variants." + )) + } + missing <- en[["Missing proportion per MI round"]] + inform(glue( + "Proportion of sampled xQTL variants missing from the GWAS PIP ", + "vector: {signif(mean(missing), 3)} (mean over {length(missing)} MI ", + "rounds); they enter the estimate with GWAS PIP 0." + )) + iterations <- en[["EM iterations per MI round"]] + if (length(iterations) > 0L) { + inform(glue( + "EM iterations per MI round: median {stats::median(iterations)} ", + "(range {min(iterations)}-{max(iterations)})." + )) + } + removed <- length(missing) - en[["Effective MI rounds"]] + if (removed > 0) { + inform(glue("Outlier filtering removed {removed} MI round(s).")) + } + invisible(NULL) } diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 6b370a4c..3b2f642b 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -1209,16 +1209,121 @@ first <- idx[[1L]] new( "FineMappingRow", - variants = .rtlGatherElements(x, idx), + variants = if (length(idx) == 1L) { + .rtlGatherElements(x, idx) + } else { + .fmrGatherVariants(x, idx) + }, susieFit = md$susieFit[[first]], cvResult = md$cvResult[[first]], - fitVariants = .mdFitVariants(md, idx) + derivedColumns = .mdDerivedColumns(md, idx) ) } -# The variants the fit of rows `idx` was made with, in its order: the first -# row's, as the fit payload is, since rows split from one entry repeat both. -# None for a collection saved before rows recorded them. +# The credible-set columns rows `idx` record as derived: the first row's, as +# with the fit. None for a collection saved before rows recorded them. +# @noRd +.mdDerivedColumns <- function(md, idx) { + dc <- md$derivedColumns + if (is.null(dc)) { + return(character(0)) + } + as.character(dc[[idx[[1L]]]]) +} + +# The elements of rows `idx`, concatenated, each with the columns its own fit +# gives back restored (.fmRowRestoredVariants()) -- before they are joined, +# since a joined entry keeps only the first row's fit. +# @noRd +.fmrGatherVariants <- function(x, idx) { + gr <- .rtlGatherElements(x, idx) + if (length(gr) == 0L) { + return(gr) + } + pip <- mcols(gr, use.names = FALSE)$pip + recorded <- mcols(x, use.names = FALSE)$derivedColumns + anyRecorded <- !is.null(recorded) && any(lengths(recorded[idx]) > 0L) + if (!is.null(pip) && !anyNA(pip) && !anyRecorded) { + return(gr) + } + restored <- .fmrRestoreAbsentColumns(x, idx, gr) + if (!is.null(restored)) { + return(restored) + } + pieces <- unname(map(idx, .fmrRowVariantsAt, x = x)) + suppressWarnings(exec(c, !!!pieces)) +} + +# The joined elements `gr` of rows `idx` with their pip and credible-set +# columns restored in one pass -- each row giving plain vectors, inserted +# once -- when no row stores any of those columns and every row records the +# same ones as derived: a trimmed collection, the genome-wide case. NULL +# otherwise, and when some row's fit cannot give them, for the row-by-row +# restore (.fmRowRestoredVariants()) to handle. +# @noRd +.fmrRestoreAbsentColumns <- function(x, idx, gr) { + records <- map(idx, .mdDerivedColumns, md = mcols(x, use.names = FALSE)) + if (!all(map_lgl(records, identical, records[[1L]]))) { + return(NULL) + } + record <- .fmRowCsRecord(records[[1L]]) + csCols <- c(record$labels, str_c(record$labels, "_purity")) + cn <- colnames(mcols(gr, use.names = FALSE)) + if (any(is_in(c("pip", csCols), cn))) { + return(NULL) + } + pieces <- map(idx, .fmrRowDerivedColumns, x = x, record = record) + if (any(map_lgl(pieces, is.null))) { + return(NULL) + } + joined <- map(set_names(names(pieces[[1L]])), .joinedField, parts = pieces) + withCs <- if (length(record$labels) > 0L) { + .fmRowInsertColumns(gr, joined[csCols], .fmRowCsSlot(cn)) + } else { + gr + } + .fmRowInsertColumns( + withCs, + joined["pip"], + .fmRowPipSlot(colnames(mcols(withCs, use.names = FALSE))) + ) +} + +# Row i's credible-set columns `record` names, then its pip, as its fit gives +# them; NULL when the fit gives no PIPs or not those sets. Positional for a +# row holding all of its fit, so no id is rendered. +# @noRd +.fmrRowDerivedColumns <- function(i, x, record) { + fit <- mcols(x, use.names = FALSE)$susieFit[[i]] + pip <- if (is.list(fit)) fit[["pip"]] + if (!is.numeric(pip)) { + return(NULL) + } + n <- length(x[[i]]) + cols <- if (.rowHoldsFit(n, length(pip))) { + seq_len(n) + } else { + .fitColumnsPlaced(x[[i]], fit) + } + cs <- if (length(record$labels) > 0L) { + .fitCsColumns(fit, record$labels, record$tag, cols, n) + } else { + list() + } + if (is.null(cs)) { + return(NULL) + } + c(cs, list(pip = as.numeric(pip)[cols])) +} + +# @noRd +.fmrRowVariantsAt <- function(i, x) { + .fmRowRestoredVariants(.fmrRowParts(x, i)) +} + +# The variants the fits of TWAS rows `idx` were made with, in their order: +# the first row's, as the fit payload is, since rows split from one entry +# repeat both. None for a collection saved before rows recorded them. # @noRd .mdFitVariants <- function(md, idx) { fv <- md$fitVariants @@ -1245,7 +1350,7 @@ # @noRd .fmrPartsTopLoci <- function(parts) { - .fmeTopLociFromElement(variants(.asFmRowPayload(parts))) + .fmeTopLociFromElement(.fmRowRestoredVariants(.asFmRowPayload(parts))) } # ---- per-row views ---------------------------------------------------------- @@ -1347,7 +1452,13 @@ # @noRd .fmrRowCredibleSetSummary <- function(parts, coverage = 0.95) { - .csSummaryFit(.fmrPartsTopLoci(parts), susieFit(parts), coverage) + fit <- susieFit(parts) + .csSummaryFit( + .fmrPartsTopLoci(parts), + fit, + coverage, + .partsFitIds(parts, fit$alpha) + ) } # @noRd @@ -1437,26 +1548,196 @@ # describes the run on all of its variants, so reading it from a row that # holds fewer warns. Nothing is rescaled: intersectVariants() is the explicit # way to restrict a fit. +# +# A fine-mapping row is built from its fit, holding the fit's variables in the +# fit's order (FineMappingRow()), so a row as long as its fit is read off it +# by position, with no id compared; only a row narrowed since -- shorter than +# its fit -- is found in the fit by the names the fit gives its variables. -# The variants a row's stored fit was made with. +# How many variables `fit` was made with: the length of its PIP vector, else +# the columns of `mat` (one of its matrices) when given, else of its `alpha`. +# The PIPs come first because a null_weight fit's effect matrices carry one +# more column, the null, which is no variable. NA for a fit that gives none +# of them: no fit, or a merged entry's list of per-region fits. # @noRd -.rowFitVariants <- function(parts) { - if (methods::is(parts, "TwasWeightsRow")) { - return(.twRowFitVariants(parts)) +.fitWidth <- function(fit, mat = NULL) { + pip <- if (is.list(fit)) fit[["pip"]] + if (is.numeric(pip)) { + return(length(pip)) + } + if (!is.null(mat)) { + return(ncol(mat)) } - .fmRowFitVariants(parts) + alpha <- if (is.list(fit)) fit[["alpha"]] + if (!is.null(dim(alpha))) { + return(ncol(alpha)) + } + NA_integer_ +} + +# The names `fit` gives its variables: those of its PIP vector, else of the +# columns of `mat` (one of its matrices) when given, else of its `alpha`. +# NULL when it gives none, as a trimmed fit of a row not narrowed does not +# (trimFineMappingResult()). +# @noRd +.fitVariableNames <- function(fit, mat = NULL) { + if (!is.list(fit)) { + return(colnames(mat)) + } + names(fit[["pip"]]) %||% colnames(mat) %||% colnames(fit[["alpha"]]) } -# The fit's variables in its own order: the ids the row recorded when it was -# built, else the names the fit's matrix `mat` carries, else -- an unnamed fit -# of a row saved before rows recorded them -- the row's variants as they are. +# Whether a row of `n` variants holds all of a fit of `width` variables. A fit +# of unknown width is taken to describe the row as it is. +# @noRd +.rowHoldsFit <- function(n, width) { + is.na(width) || n == width +} + +# For each variant of `gr`, its column among the variables of `fit` (or of +# its matrix `mat`): positional when `gr` holds all of them, else found by +# the names the fit gives them (.fitColumnOf(); NA for a variant it was not +# made with). NULL when `gr` is narrowed and the fit names none, which +# leaves nothing to place the variants by. +# @noRd +.fitColumnsFor <- function(gr, fit, mat = NULL) { + n <- length(gr) + if (.rowHoldsFit(n, .fitWidth(fit, mat))) { + return(seq_len(n)) + } + fitted <- .fitVariableNames(fit, mat) + if (is.null(fitted)) { + return(NULL) + } + .fitColumnOf(.grVariantIds(gr), fitted) +} + +# The fit's variables in its own order. For a fine-mapping row holding all of +# them, its own variants; for one narrowed since, the names the fit (or its +# matrix `mat`) gives them -- an error when it gives none. For a TWAS row, the +# ids it recorded when it was built, else the names `mat` carries, else the +# row's variants as they are. # @noRd .partsFitIds <- function(parts, mat = NULL) { - recorded <- .rowFitVariants(parts) - if (length(recorded) > 0L) { - return(recorded) + if (methods::is(parts, "TwasWeightsRow")) { + recorded <- .twRowFitVariants(parts) + if (length(recorded) > 0L) { + return(recorded) + } + return(colnames(mat) %||% variantIds(parts)) + } + fit <- susieFit(parts) + n <- length(variants(parts)) + width <- .fitWidth(fit, mat) + if (.rowHoldsFit(n, width)) { + return(variantIds(parts)) + } + .fitVariableNames(fit, mat) %||% .abortUnnamedNarrowedFit(n, width) +} + +# The variants of the fits `fits` of rows `idx` of a fine-mapping collection, +# in each fit's order, read for all the rows at once as one variant table +# (.variantTable()), row after row: list(table, n), `n` each row's count (NA +# for a row placed nowhere, which contributes none). A fit's variants are the +# names it gives its PIPs; else, for a row holding all of its fit, the row's +# own variants, read off its ranges without rendering an id; else, for a +# narrowed row, the names the fit gives its variables. A narrowed row whose +# fit names none is placed nowhere when `onUnplaced` is "skip", and is an +# error when it is "error" (.abortUnnamedNarrowedFit()). +# @noRd +#' @importFrom purrr map2_lgl pmap +.fmrRowsFitVariants <- function(x, idx, fits, onUnplaced = c("skip", "error")) { + rule <- arg_match(onUnplaced) + n <- unname(lengths(x))[idx] + widths <- map_int(fits, .fitWidth) + pipNames <- map(fits, .fitPipNames) + fromRows <- map_lgl(pipNames, is.null) & map2_lgl(n, widths, .rowHoldsFit) + named <- pmap( + list(pipNames, fits, fromRows, n, widths), + .fmrRowFitNames, + onUnplaced = rule + ) + len <- if_else( + fromRows | !map_lgl(named, is.null), + if_else(fromRows, n, lengths(named)), + NA_integer_ + ) + if (all(fromRows)) { + return(list(table = .variantTable(.rtlGatherElements(x, idx)), n = len)) + } + list(table = .fmrRowsFitTable(x, idx, named, fromRows, len), n = len) +} + +# @noRd +.fitPipNames <- function(fit) { + names(fit[["pip"]]) +} + +# The names one row's fit gives its variants (see .fmrRowsFitVariants()): its +# PIPs' names, or none for a row read off its own ranges (`fromRows`); else, +# for a narrowed row, the names the fit gives its variables. +# @noRd +.fmrRowFitNames <- function(pipNames, fit, fromRows, n, width, onUnplaced) { + if (!is.null(pipNames) || fromRows) { + return(pipNames) + } + named <- .fitVariableNames(fit) + if (is.null(named) && onUnplaced == "error") { + .abortUnnamedNarrowedFit(n, width) + } + named +} + +# The variant table of rows `idx` (see .fmrRowsFitVariants()), row after row: +# the rows read off their own ranges in one read, and the rest from the names +# their fits give in one parse, each placed at its rows' slots. +# @noRd +.fmrRowsFitTable <- function(x, idx, named, fromRows, len) { + counts <- coalesce(len, 0L) + starts <- cumsum(c(0L, counts))[seq_along(counts)] + empty <- .naVariantTable(sum(counts)) + withRows <- if (any(fromRows)) { + .variantTableWithRows( + empty, + .rowSlots(which(fromRows), starts, counts), + .variantTable(.rtlGatherElements(x, idx[fromRows])) + ) + } else { + empty + } + byName <- which(!fromRows & !is.na(len)) + if (length(byName) == 0L) { + return(withRows) } - colnames(mat) %||% variantIds(parts) + .variantTableWithRows( + withRows, + .rowSlots(byName, starts, counts), + .idsVariantTable(list_c(named[byName])) + ) +} + +# The positions rows `ks` take in a table of rows laid out row after row, +# row k starting after `starts[k]` and holding `counts[k]`. +# @noRd +.rowSlots <- function(ks, starts, counts) { + rep(starts[ks], counts[ks]) + sequence(counts[ks]) +} + +# The fits of rows `idx` of a fine-mapping collection, as a list. +# @noRd +.fmrFitsAt <- function(x, idx) { + as.list(mcols(x, use.names = FALSE)$susieFit[idx]) +} + +# @noRd +.abortUnnamedNarrowedFit <- function(n, width) { + abort(glue( + "The row holds {n} variants but its fit was made with {width}, and ", + "the fit does not name its variables, so the row's variants cannot ", + "be placed in it. Narrow the row before trimming it ", + "(trimFineMappingResult() keeps the names of a narrowed row's fit), ", + "or refit on the variants kept." + )) } # How many of `fitted` are gone from `held`. A variant whose alleles @@ -1476,6 +1757,11 @@ # has none), matched the same allele-aware way. # @noRd .fitColumnOf <- function(held, fitted) { + # The usual case, a row holding exactly its fit's variables in order, + # needs no hashing. + if (identical(held, fitted)) { + return(seq_along(held)) + } col <- match(held, fitted) miss <- which(is.na(col)) if (length(miss) == 0L) { @@ -1485,19 +1771,36 @@ replace(col, miss[m$idxA], m$idxB) } +# How many of the variables a row's fit was made with the row no longer +# holds, with the fit's size: a fine-mapping row is short by however many +# fewer variants it holds than its fit has; a TWAS row by the recorded ids it +# no longer holds. +# @noRd +.partsLostFitVariants <- function(parts) { + if (methods::is(parts, "TwasWeightsRow")) { + fitted <- .twRowFitVariants(parts) + return(list( + width = length(fitted), + lost = .lostFitVariantCount(fitted, variantIds(parts)) + )) + } + width <- .fitWidth(susieFit(parts)) + n <- length(variants(parts)) + list(width = width, lost = if (is.na(width)) 0L else max(width - n, 0L)) +} + # `parts` unchanged, after warning when its row holds fewer variants than its # stored fit was made with. # @noRd .fitCoverageChecked <- function(parts, caller) { - fitted <- .rowFitVariants(parts) - lost <- .lostFitVariantCount(fitted, variantIds(parts)) - if (lost > 0L) { + short <- .partsLostFitVariants(parts) + if (short$lost > 0L) { warn( c( glue( "{caller}: the stored fit was made with ", - "{length(fitted)} variants, {lost} of which this row no ", - "longer holds." + "{short$width} variants, {short$lost} of which this row ", + "no longer holds." ), i = .fitCoverageHint(parts) ), @@ -1539,20 +1842,31 @@ } # The labels of the rows of `x` that hold fewer variants than their stored -# fit was made with. None when `x` records no fit variants, or is not a -# collection at all: an optional input left NULL, or one the caller has yet -# to validate, which this advisory check must not pre-empt. +# fit was made with: for fine-mapping rows, those shorter than their fit, +# which needs no ids; for TWAS rows, those missing some of the variants they +# recorded. None when `x` has no fits to compare, or is not a collection at +# all: an optional input left NULL, or one the caller has yet to validate, +# which this advisory check must not pre-empt. # @noRd .narrowedRowLabels <- function(x) { - if (!methods::is(x, "RangedTupleList")) { + if (!methods::is(x, "RangedTupleList") || length(x) == 0L) { return(character(0)) } - fv <- mcols(x, use.names = FALSE)$fitVariants - if (is.null(fv) || length(x) == 0L) { - return(character(0)) + md <- mcols(x, use.names = FALSE) + if (.isFineMappingPayload(x)) { + if (is.null(md$susieFit)) { + return(character(0)) + } + width <- map_int(as.list(md$susieFit), .fitWidth) + short <- which(!is.na(width) & lengths(x) < width) + } else { + fv <- md$fitVariants + if (is.null(fv)) { + return(character(0)) + } + lost <- map_int(seq_along(x), .rowLostFitVariants, x = x, fv = fv) + short <- which(lost > 0L) } - lost <- map_int(seq_along(x), .rowLostFitVariants, x = x, fv = fv) - short <- which(lost > 0L) if (length(short) == 0L) { return(character(0)) } diff --git a/R/variantId.R b/R/variantId.R index 0a585bfe..306fbae5 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -61,10 +61,17 @@ canonChromLabel <- function(x) { #' @return Character vector of UCSC-style chromosome names. #' @noRd withChrPrefix <- function(x) { - bare <- str_remove(as.character(x), regex("^chr", ignore_case = TRUE)) + # Worked out once per distinct label: a variant table has millions of + # rows but a few dozen chromosomes. + labels <- unique(as.character(x)) + bare <- str_remove(labels, regex("^chr", ignore_case = TRUE)) canon <- canonChrom(bare) standard <- is_in(canon, .STANDARD_CHROMS) - str_c("chr", if_else(standard, str_replace(canon, "^MT$", "M"), bare)) + out <- str_c( + "chr", + if_else(standard, str_replace(canon, "^MT$", "M"), bare) + ) + out[match(as.character(x), labels)] } # The chromosomes withChrPrefix() spells as UCSC does, in canonChrom() form. @@ -147,7 +154,17 @@ chromOrder <- function(x) { #' @param x Character vector of variant IDs. #' @return Character vector with build suffix removed. #' @noRd -stripBuildSuffix <- function(x) str_remove(x, "(:|_)b[0-9]+$") +stripBuildSuffix <- function(x) { + # The regex only where a suffix could be: nearly no id carries one, and + # a fixed-string scan costs a fraction of a regex over millions of ids. + candidate <- which( + str_detect(x, fixed(":b")) | str_detect(x, fixed("_b")) + ) + if (length(candidate) == 0L) { + return(x) + } + replace(x, candidate, str_remove(x[candidate], "(:|_)b[0-9]+$")) +} #' Test whether allele pairs are single-nucleotide (SNP, not indel). #' @@ -308,11 +325,7 @@ parseVariantId <- function(ids) { return(.parseVariantIdDf(ids)) } convention <- detectVariantConvention(ids) - # Normalize: convert underscores to colons, strip build suffix. - normalized <- stripBuildSuffix(str_replace_all(ids, "_", ":")) - # Split into exactly 4 fields via a single vectorized regex match; a - # non-matching id yields an all-NA capture row (mirrors strcapture). - m <- str_match(normalized, "^([^:]+):([^:]+):([^:]+):([^:]+)") + m <- .variantIdFields(ids) data <- tibble( chrom = withChrPrefix(m[, 2L]), pos = as.integer(m[, 3L]), @@ -322,6 +335,16 @@ parseVariantId <- function(ids) { `attr<-`(data, "convention", convention) } +# The fields of variant ids as every parser reads them: underscores read as +# colons and a build suffix dropped, then exactly 4 fields split by a single +# vectorized regex match. A non-matching id yields an all-NA capture row +# (mirrors strcapture). +# @noRd +.variantIdFields <- function(ids) { + normalized <- stripBuildSuffix(str_replace_all(ids, fixed("_"), ":")) + str_match(normalized, "^([^:]+):([^:]+):([^:]+):([^:]+)") +} + # `[[<-` rather than mutate(): callers hand this frame straight through from # a user-supplied table, which may carry NA or "" column names -- and # dplyr refuses to transform such a frame at all. @@ -412,7 +435,14 @@ formatVariantId <- function( } # UCSC style is pecotmr's own; the bare form is for a consumer that wants # it (canonChrom keeps X/Y/MT as strings). - chromOut <- if (chrPrefix) withChrPrefix(chrom) else canonChrom(chrom) + # Over the distinct labels only: millions of variants, a few dozen + # chromosomes (withChrPrefix() does the same). + chromOut <- if (chrPrefix) { + withChrPrefix(chrom) + } else { + labels <- unique(chrom) + canonChrom(labels)[match(chrom, labels)] + } str_c(chromOut, ":", pos, alleleSep, A2, alleleSep, A1) } @@ -448,8 +478,19 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { assertCharacter(ids) assertFlag(chrPrefix) assertList(convention, null.ok = TRUE) - parsed <- parseVariantId(ids) out <- as.character(ids) + # An id already in the canonical form re-formats to itself, and a + # genotype panel's millions of ids usually all are: one regex finds them, + # where parsing and re-rendering every one costs several times as much. + todo <- if (chrPrefix && is.null(convention)) { + which(!str_detect(out, .CANONICAL_VARIANT_ID)) + } else { + seq_along(out) + } + if (length(todo) == 0L) { + return(out) + } + parsed <- parseVariantId(out[todo]) # Only re-format ids that parsed into a chrom + pos; leave unparseable ids # (e.g. rsIDs) unchanged rather than emitting "chrNA:..." garbage. ok <- !is.na(parsed$chrom) & !is.na(parsed$pos) @@ -473,9 +514,18 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { chrPrefix = chrPrefix ) } - replace(out, ok, reformatted) + replace(out, todo[ok], reformatted) } +# The ids normalizeVariantId() returns unchanged in its default convention: a +# UCSC chromosome, a position without leading zeros, and two alleles, with +# no build suffix and no underscore. +# @noRd +.CANONICAL_VARIANT_ID <- str_c( + "^chr(1[0-9]|2[0-2]|[1-9]|X|Y|M)", + ":[1-9][0-9]*:[^:_]+:[^:_]+$" +) + # Complement a DNA allele string (A<->T, C<->G) for strand flipping. # @noRd .strandFlip <- function(ref) chartr("ATCG", "TAGC", ref) @@ -521,8 +571,10 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { #' @param flip Whether the alleles must be flipped: A <--> T & C <--> G, in #' which case corresponding `colToFlip` are multiplied by -1. Default is #' `TRUE`. -#' @param removeStrandAmbiguous Whether to remove strand SNPs (if any). Default -#' is `TRUE`. +#' @param removeStrandAmbiguous Whether to drop a strand-ambiguous match (A/T +#' or C/G alleles, where a strand flip and an allele swap look the same). +#' Each target-reference pair is judged on its own, whatever else is being +#' harmonized; an exact A/T match is kept. Default is `TRUE`. #' @param flipStrand Whether to output the variants after strand flip. Default #' is `FALSE`. #' @param removeUnmatched Whether to remove unmatched variants. Default is @@ -680,19 +732,54 @@ harmonizeAlleles <- function( list(targetData = trimmedTarget, refVariants = trimmedRef) } -# Inner-join target + reference on (chrom, pos). +# Target + reference rows paired at the same (chrom, pos) by the matching +# engine (.variantPairs()), laid out as an inner join on (chrom, pos) lays +# them out: the target's columns, then the reference's other columns, the ones +# both carry suffixed ".target" / ".ref". # @noRd +#' @importFrom dplyr bind_cols .harmonizeJoin <- function(targetData, refVariants) { - inner_join( - targetData, - refVariants, - by = c("chrom", "pos"), - suffix = c(".target", ".ref") + pairs <- .variantPairs( + .frameVariantTable(targetData), + .frameVariantTable(refVariants) + ) + keys <- c("chrom", "pos") + # Indexed, not slice()d: a caller's frame may carry NA or "" column + # names, which dplyr refuses. + left <- targetData[pairs$query, , drop = FALSE] + right <- refVariants[ + pairs$subject, + !is_in(colnames(refVariants), keys), + drop = FALSE + ] + both <- setdiff(intersect(colnames(left), colnames(right)), keys) + bind_cols( + set_names(left, .suffixed(colnames(left), both, ".target")), + set_names(right, .suffixed(colnames(right), both, ".ref")), + .name_repair = "minimal" ) |> as_tibble(.name_repair = "minimal") |> .sanitizeNames() } +# `nm` with `suffix` appended to the names in `which`. +# @noRd +.suffixed <- function(nm, which, suffix) { + hit <- !is.na(nm) & is_in(nm, which) + replace(nm, hit, str_c(nm[hit], suffix)) +} + +# The variant table (.variantTable()) of a parsed chrom/pos/A2/A1 frame. +# @noRd +.frameVariantTable <- function(df) { + list( + chrom = as.character(df$chrom), + pos = as.integer(df$pos), + A2 = as.character(df$A2), + A1 = as.character(df$A1) + ) +} + # Empty-match early return (warning + zeroed qcCounts). # @noRd .harmonizeEmptyResult <- function(matchResult) { @@ -748,90 +835,56 @@ harmonizeAlleles <- function( .harmonizeMatchFlags() } -# Exact / sign-flip / strand-flip / INDEL / ID-match indicators, consuming the -# uppercased alleles and strand complements from the earlier pipe stages. +# Exact / sign-flip / strand-flip / INDEL / ID-match indicators, as the +# matching engine decides them (.variantPairFlags()), on the uppercased +# alleles from the earlier pipe stages. # @noRd .harmonizeMatchFlags <- function(matchResult) { - matchResult |> - mutate( - strand_unambiguous = if_else( - (.data$A1.target == "A" & .data$A2.target == "T") | - (.data$A1.target == "T" & .data$A2.target == "A") | - (.data$A1.target == "C" & .data$A2.target == "G") | - (.data$A1.target == "G" & .data$A2.target == "C"), - FALSE, - TRUE - ) - ) |> - mutate( - exact_match = .data$A1.target == .data$A1.ref & - .data$A2.target == .data$A2.ref - ) |> - mutate( - sign_flip = ((.data$A1.target == .data$A2.ref & - .data$A2.target == .data$A1.ref) | - (.data$A1.target == .data$flip2.ref & - .data$A2.target == .data$flip1.ref)) & - (.data$A1.target != .data$A1.ref & - .data$A2.target != .data$A2.ref) - ) |> - mutate( - strand_flip = ((.data$A1.target == .data$flip1.ref & - .data$A2.target == .data$flip2.ref) | - (.data$A1.target == .data$flip2.ref & - .data$A2.target == .data$flip1.ref)) & - (.data$A1.target != .data$A1.ref & - .data$A2.target != .data$A2.ref) - ) |> - mutate( - INDEL = (.data$A2.target == "I" | - .data$A2.target == "D" | - str_length(.data$A2.target) > 1L | - str_length(.data$A1.target) > 1L) - ) |> - mutate( - ID_match = ((.data$A2.target == "D" | .data$A2.target == "I") & - (str_length(.data$A1.ref) > 1L | - str_length(.data$A2.ref) > 1L)) - ) + f <- .variantPairFlags( + matchResult$A1.target, + matchResult$A2.target, + matchResult$A1.ref, + matchResult$A2.ref + ) + mutate( + matchResult, + strand_unambiguous = f$strandUnambiguous, + exact_match = f$exact, + sign_flip = f$signFlip, + strand_flip = f$strandFlip, + INDEL = f$indel, + ID_match = f$idMatch + ) } -# Strand-ambiguity resolution: disable the A/T-C/G guard when the caller opted -# out, and when no unambiguous strand flip survives (ambiguous variants then -# fall through as exact / sign-flip cases rather than being dropped). +# Strand-ambiguity resolution: the A/T-C/G guard is off when the caller opted +# out. Otherwise each pair is judged on its own: an ambiguous pair is not +# rescued by the rest of the batch having no strand flip. # @noRd .harmonizeResolveAmbiguity <- function(matchResult, removeStrandAmbiguous) { - relaxed <- if (removeStrandAmbiguous) { - matchResult - } else { - mutate(matchResult, strand_unambiguous = TRUE) - } - if (any(relaxed$strand_flip & relaxed$strand_unambiguous)) { - return(relaxed) + if (removeStrandAmbiguous) { + return(matchResult) } - mutate(relaxed, strand_unambiguous = TRUE) + mutate(matchResult, strand_unambiguous = TRUE) } -# Compute the keep flag (strand-flip vs non-strand-flip rules); drop indels when -# requested. +# The keep flag, as the matching engine decides it (.variantPairKeep()); the +# strand guard is already in `strand_unambiguous`. # @noRd .harmonizeKeepRule <- function(matchResult, removeIndels) { - ruled <- matchResult |> - mutate( - keep = if_else( - .data$strand_flip, - true = .data$strand_unambiguous | - .data$exact_match | - .data$ID_match, - false = .data$exact_match | - .data$sign_flip | - .data$ID_match - ) - ) - if (!removeIndels) { - return(ruled) - } - mutate(ruled, keep = if_else(.data$INDEL, FALSE, .data$keep)) + keep <- .variantPairKeep( + list( + strandUnambiguous = matchResult$strand_unambiguous, + exact = matchResult$exact_match, + signFlip = matchResult$sign_flip, + strandFlip = matchResult$strand_flip, + indel = matchResult$INDEL, + idMatch = matchResult$ID_match + ), + removeStrandAmbiguous = TRUE, + removeIndels = removeIndels + ) + mutate(matchResult, keep = keep) } # Reduce the join to at most one reference row per TARGET variant. @@ -856,36 +909,16 @@ harmonizeAlleles <- function( # the rule. # @noRd .harmonizeResolveTargets <- function(matchResult) { - tidx <- matchResult[[.haTargetIdx]] - hit <- which(matchResult$keep) - # Fast path: one reference row per target is the overwhelmingly common - # case, and it needs no grouping at all. - if (anyDuplicated(tidx[hit]) == 0L) { - return(matchResult) - } - conflicted <- .harmonizeConflictedTargets( - tidx[hit], - matchResult$sign_flip[hit] - ) - resolved <- hit[ - !is_in(tidx[hit], conflicted) & !duplicated(tidx[hit]) - ] # Named apart from the column it replaces: `keep = keep` inside mutate() # reads the column, not this vector, and silently changes nothing. - resolvedKeep <- replace(rep(FALSE, nrow(matchResult)), resolved, TRUE) + resolvedKeep <- .variantPairResolve( + matchResult[[.haTargetIdx]], + matchResult$keep, + matchResult$sign_flip + ) mutate(matchResult, keep = resolvedKeep) } -# Target indices whose reference matches disagree about the allele-swap sign. -# @noRd -.harmonizeConflictedTargets <- function(tidx, signFlip) { - tibble(tidx = tidx, signFlip = signFlip) |> - group_by(.data$tidx) |> - summarise(nSigns = n_distinct(.data$signFlip), .groups = "drop") |> - filter(.data$nSigns > 1L) |> - pull("tidx") -} - # Named per-row conditional column transforms for the harmonize across() calls. # The `flip` condition vector is bound with purrr::partial() rather than passed # through across()'s `...`, which dplyr deprecated in 1.1.0 -- partial() fixes @@ -1104,6 +1137,188 @@ harmonizeAlleles <- function( } } +# ============================================================================= +# The variant matching engine +# ----------------------------------------------------------------------------- +# Variants are paired by position first -- overlaps of width-1 ranges, so a +# window (`maxDistance`) costs nothing extra -- and their alleles decided +# second, pair by pair: exact, ref/alt swap (sign -1), strand flip, the I/D +# codes. matchVariants() and harmonizeAlleles() both decide through it, so the +# two cannot disagree about which variants match. +# ============================================================================= + +# A variant table: canonical chromosome labels, positions and both alleles, +# from a GRanges (A1/A2 metadata columns), variant ids, or a chrom/pos/A2/A1 +# data.frame (parseVariantId()). Chromosomes are relabelled over their distinct +# values only (withChrPrefix()), so a genome-wide GRanges costs one pass. +# @noRd +.variantTable <- function(x) { + if (methods::is(x, "GRanges")) { + mc <- mcols(x, use.names = FALSE) + if (!all(is_in(c("A1", "A2"), colnames(mc)))) { + abort("A GRanges of variants needs A1 and A2 metadata columns.") + } + labels <- withChrPrefix(as.character(GenomeInfoDb::seqlevels(x))) + return(list( + chrom = labels[as.integer(seqnames(x))], + pos = start(x), + A2 = as.character(mc$A2), + A1 = as.character(mc$A1) + )) + } + p <- parseVariantId(x) + list( + chrom = as.character(p$chrom), + pos = as.integer(p$pos), + A2 = as.character(p$A2), + A1 = as.character(p$A1) + ) +} + +# The pairs of variants of tables `a` and `b` on one chromosome at most +# `maxDistance` bp apart, as list(query, subject) indices, in query then +# subject order -- the order a join on (chrom, pos) gives. A variant with no +# chromosome or position pairs with none. +# @noRd +#' @importFrom IRanges findOverlaps IRanges +.variantPairs <- function(a, b, maxDistance = 0L) { + chromLevels <- setdiff(c(a$chrom, b$chrom), NA) + ra <- .variantPairRanges(a, chromLevels) + rb <- .variantPairRanges(b, chromLevels) + hits <- findOverlaps( + ra$gr, + rb$gr, + maxgap = as.integer(maxDistance) - 1L, + ignore.strand = TRUE + ) + q <- ra$rows[S4Vectors::queryHits(hits)] + sbj <- rb$rows[S4Vectors::subjectHits(hits)] + o <- order(q, sbj) + list(query = q[o], subject = sbj[o]) +} + +# @noRd +.variantPairRanges <- function(x, levels) { + rows <- which(!is.na(x$chrom) & !is.na(x$pos)) + gr <- GenomicRanges::GRanges( + factor(x$chrom[rows], levels = levels), + IRanges(x$pos[rows], width = 1L) + ) + list(gr = gr, rows = rows) +} + +# `x` upper-cased, over its distinct values (alleles are few). +# @noRd +.upperAlleles <- function(x) { + u <- unique(x) + str_to_upper(u)[match(x, u)] +} + +# The allele relationship of each pair of a target variant (alleles `a1t`, +# `a2t`) with a reference variant (`a1r`, `a2r`): exact; a ref/alt swap, or a +# swap of the complements (`signFlip`); a strand flip; an indel; an I/D-coded +# target meeting a reference indel (`idMatch`); and whether the target's +# alleles leave the strand undecidable (A/T, C/G). Case-insensitive. +# @noRd +.variantPairFlags <- function(a1t, a2t, a1r, a2r) { + t1 <- .upperAlleles(a1t) + t2 <- .upperAlleles(a2t) + r1 <- .upperAlleles(a1r) + r2 <- .upperAlleles(a2r) + flip1 <- .strandFlip(r1) + flip2 <- .strandFlip(r2) + differ <- t1 != r1 & t2 != r2 + list( + strandUnambiguous = !((t1 == "A" & t2 == "T") | + (t1 == "T" & t2 == "A") | + (t1 == "C" & t2 == "G") | + (t1 == "G" & t2 == "C")), + exact = t1 == r1 & t2 == r2, + signFlip = ((t1 == r2 & t2 == r1) | + (t1 == flip2 & t2 == flip1)) & + differ, + strandFlip = ((t1 == flip1 & t2 == flip2) | + (t1 == flip2 & t2 == flip1)) & + differ, + indel = t2 == "I" | + t2 == "D" | + str_length(t2) > 1L | + str_length(t1) > 1L, + idMatch = (t2 == "D" | t2 == "I") & + (str_length(r1) > 1L | str_length(r2) > 1L) + ) +} + +# Whether each pair matches: a strand flip only when the target's alleles +# decide the strand (each pair judged on its own), an exact pair, or an I/D +# match; any other pair when exact, swapped or I/D-matched. Indels are refused +# when `removeIndels`. NA where an allele is missing. +# @noRd +.variantPairKeep <- function(flags, removeStrandAmbiguous, removeIndels) { + decided <- if (removeStrandAmbiguous) flags$strandUnambiguous else TRUE + allelesMatch <- if_else( + flags$strandFlip, + decided | flags$exact | flags$idMatch, + flags$exact | flags$signFlip | flags$idMatch + ) + if (!removeIndels) { + return(allelesMatch) + } + if_else(flags$indel, FALSE, allelesMatch) +} + +# `keep` with each target settled on at most one reference variant. A target +# whose kept pairs disagree about the swap sign is undecidable and dropped -- +# its effect direction would depend on the reference's row order --; one whose +# pairs agree keeps the first. Unchanged when no target has two. +# @noRd +#' @importFrom vctrs vec_unique_loc +.variantPairResolve <- function(query, keep, signFlip) { + hit <- which(keep) + target <- query[hit] + if (anyDuplicated(target) == 0L) { + return(keep) + } + distinctSigns <- vec_unique_loc(tibble( + target = target, + sign = signFlip[hit] + )) + nSigns <- tabulate(target[distinctSigns], nbins = max(target)) + resolved <- hit[nSigns[target] == 1L & !duplicated(target)] + replace(rep(FALSE, length(keep)), resolved, TRUE) +} + +# The matched (a, b) pairs of variant tables `a` and `b`: paired within +# `maxDistance`, decided by their alleles, each target settled on one +# reference variant, and each reference variant (its alleles as given) +# claimed by the first target only. list(idxA, idxB, sign), by idxA. +# @noRd +.matchVariantTables <- function( + a, + b, + maxDistance = 0L, + removeStrandAmbiguous = TRUE, + removeIndels = FALSE +) { + pairs <- .variantPairs(a, b, maxDistance) + q <- pairs$query + sbj <- pairs$subject + if (length(q) == 0L) { + return(.matchVariantsEmpty()) + } + flags <- .variantPairFlags(a$A1[q], a$A2[q], b$A1[sbj], b$A2[sbj]) + keep <- .variantPairKeep(flags, removeStrandAmbiguous, removeIndels) + kept <- which(is_in(.variantPairResolve(q, keep, flags$signFlip), TRUE)) + claimed <- kept[vec_unique_loc( + .variantKeyFrame(.variantTableRows(b, sbj[kept])) + )] + list( + idxA = q[claimed], + idxB = sbj[claimed], + sign = if_else(flags$signFlip[claimed], -1, 1) + ) +} + #' Allele-aware variant matcher (match by chrom/pos/ref/alt, not id string) #' #' The single matching primitive for the package: given two sets of variant @@ -1116,14 +1331,16 @@ harmonizeAlleles <- function( #' classification to \code{harmonizeAlleles}): an allele swap is matched and #' reported with \code{sign = -1} so callers can sign-flip a paired effect / z / #' weight; strand flips are resolved; and strand-ambiguous (A/T, C/G) matches -#' are dropped when \code{removeStrandAmbiguous = TRUE}. +#' are dropped when \code{removeStrandAmbiguous = TRUE}, each pair judged on +#' its own. #' #' When ids cannot be parsed into chrom/pos/ref/alt (e.g. rsIDs), the matcher #' falls back to exact string identity with \code{sign = 1} (no allele awareness #' is possible without alleles). #' -#' @param idsA,idsB Character vectors of variant IDs, or data.frames with -#' chrom/pos/A2/A1 columns (A2 = ref, A1 = alt). +#' @param idsA,idsB Character vectors of variant IDs, data.frames with +#' chrom/pos/A2/A1 columns (A2 = ref, A1 = alt), or GRanges of variants with +#' A1/A2 metadata columns. #' @param allowFlip When TRUE (default) match by (chrom, pos) with ref/alt swap #' and strand handling, reporting \code{sign = -1} for a swap. When FALSE, #' match on exact alleles only (canonicalized format; \code{sign} always +1) @@ -1131,6 +1348,9 @@ harmonizeAlleles <- function( #' @param removeStrandAmbiguous Drop strand-ambiguous (A/T, C/G) matches. #' Default TRUE (mirrors summaryStatsQc). #' @param removeIndels Drop indels. Default FALSE. +#' @param maxDistance Largest distance in bp between the positions of two +#' variants that may match; their alleles must still agree. Default 0: the +#' same position. #' @return A list of three equal-length vectors describing the matched pairs: #' \code{idxA} / \code{idxB} (indices into \code{idsA} / \code{idsB}) and #' \code{sign} (+1 exact, -1 allele-swap). At most one pair per \code{idsA} @@ -1141,9 +1361,11 @@ matchVariants <- function( idsB, allowFlip = TRUE, removeStrandAmbiguous = TRUE, - removeIndels = FALSE + removeIndels = FALSE, + maxDistance = 0L ) { - if (!allowFlip) { + ranged <- methods::is(idsA, "GRanges") || methods::is(idsB, "GRanges") + if (!allowFlip && !ranged && maxDistance == 0L) { # Exact-allele matching: canonicalize the id FORMAT (chr-prefix + # separator, rsID-safe) but keep allele order, then match by exact # string identity, so a ref/alt swap does NOT match (sign is always +1). @@ -1152,9 +1374,9 @@ matchVariants <- function( .matchVariantKeyOf(idsB) )) } - dfA <- parseVariantId(idsA) - dfB <- parseVariantId(idsB) - if (.matchVariantsUnparseable(dfA, dfB)) { + tabA <- .variantTable(idsA) + tabB <- .variantTable(idsB) + if (!ranged && .matchVariantsUnparseable(tabA, tabB)) { # rsID / unparseable ids: exact string identity only (no allele # awareness). data.frame inputs have no string form to fall back to. if (is.data.frame(idsA) || is.data.frame(idsB)) { @@ -1162,7 +1384,32 @@ matchVariants <- function( } return(.matchVariantsExact(as.character(idsA), as.character(idsB))) } - .matchVariantsHarmonized(dfA, dfB, removeIndels, removeStrandAmbiguous) + if (!allowFlip) { + return(.matchVariantTablesExact(tabA, tabB, maxDistance)) + } + .matchVariantTables( + tabA, + tabB, + maxDistance, + removeStrandAmbiguous, + removeIndels + ) +} + +# Pairs with exactly the same alleles in the same order (sign +1): the first +# reference variant for each target, within `maxDistance`. +# @noRd +.matchVariantTablesExact <- function(a, b, maxDistance = 0L) { + pairs <- .variantPairs(a, b, maxDistance) + q <- pairs$query + sbj <- pairs$subject + same <- which(a$A2[q] == b$A2[sbj] & a$A1[q] == b$A1[sbj]) + first <- same[!duplicated(q[same])] + list( + idxA = q[first], + idxB = sbj[first], + sign = rep(1, length(first)) + ) } # The empty match result. @@ -1186,53 +1433,193 @@ matchVariants <- function( # TRUE when either parsed side lacks usable chrom/pos (rsID / unparseable ids). # @noRd .matchVariantsUnparseable <- function(dfA, dfB) { - nrow(dfA) == 0L || - nrow(dfB) == 0L || + length(dfA$pos) == 0L || + length(dfB$pos) == 0L || anyNA(dfA$chrom) || anyNA(dfA$pos) || anyNA(dfB$chrom) || anyNA(dfB$pos) } -# Allele-aware match via harmonizeAlleles, reading the matched pairs + swap sign -# back out of the injected sentinel columns. +# The variant table (.variantTable()) of variant ids, read as parseVariantId() +# reads them (NA fields for an id that does not parse). A canonical id +# ("chr1:100:A:G") is split on its separator, at a fraction of the cost of the +# regex every other spelling takes: a genome-wide panel holds millions. # @noRd -.matchVariantsHarmonized <- function( - dfA, - dfB, - removeIndels, - removeStrandAmbiguous -) { - # Inject sentinel index/sign columns so the matched pairs and the swap sign - # can be read straight back out of harmonizeAlleles without re-deriving - # them. - tagA <- mutate(dfA, .mvTidx = seq_len(nrow(dfA)), .mvSign = 1) - tagB <- mutate(dfB, .mvRidx = seq_len(nrow(dfB))) - res <- suppressWarnings(harmonizeAlleles( - targetData = tagA, - refVariants = tagB, - colToFlip = ".mvSign", - matchMinProp = 0, - removeDups = TRUE, - flipStrand = FALSE, - removeIndels = removeIndels, - removeStrandAmbiguous = removeStrandAmbiguous, - removeUnmatched = TRUE - )) - h <- res$harmonizedData - if (is.null(h) || nrow(h) == 0L) { - return(.matchVariantsEmpty()) +.idsVariantTable <- function(ids) { + spelled <- as.character(ids) + canon <- coalesce(str_detect(spelled, .CANONICAL_VARIANT_ID), FALSE) + if (all(canon)) { + return(.canonicalVariantTable(spelled)) } - # One row per A id, sign-conflicting ids already dropped: harmonizeAlleles - # resolves that (see .harmonizeResolveTargets), so there is nothing to - # decide a second time here. + withCanon <- .variantTableWithRows( + .naVariantTable(length(spelled)), + which(canon), + .canonicalVariantTable(spelled[canon]) + ) + parsed <- .variantTableWithRows( + withCanon, + which(!canon), + .variantTable(spelled[!canon]) + ) + .unparsedAsSpelled(parsed, spelled) +} + +# A variant table of `n` variants with every field missing. +# @noRd +.naVariantTable <- function(n) { list( - idxA = as.integer(h$.mvTidx), - idxB = as.integer(h$.mvRidx), - sign = as.numeric(h$.mvSign) + chrom = rep(NA_character_, n), + pos = rep(NA_integer_, n), + A2 = rep(NA_character_, n), + A1 = rep(NA_character_, n) ) } +# The variant table `tab` with its rows `rows` taken, in order, from the +# variant table `from`. +# @noRd +.variantTableWithRows <- function(tab, rows, from) { + map2(tab, from[names(tab)], .replaceRows, rows = rows) +} + +# @noRd +.replaceRows <- function(column, values, rows) { + replace(column, rows, values) +} + +# A variant table's rows whose id did not parse (an rsID), each made a variant +# of its own: on a chromosome named after the id, at position 1, with the id +# as its A2 and no A1. Such a variant pairs only with the same spelling, and +# matches it exactly, so an id without coordinates is matched by its spelling +# while the rest are matched by their variants. +# @noRd +.unparsedAsSpelled <- function(tab, ids) { + bad <- (is.na(tab$chrom) | is.na(tab$pos)) & !is.na(ids) + if (!any(bad)) { + return(tab) + } + list( + chrom = if_else(bad, str_c(.UNPARSED_CHROM, ids), tab$chrom), + pos = if_else(bad, 1L, tab$pos), + A2 = if_else(bad, ids, tab$A2), + A1 = if_else(bad, "", tab$A1) + ) +} + +# The chromosome-name prefix of the variants .unparsedAsSpelled() makes. +.UNPARSED_CHROM <- "" + +# The ids of a variant table's variants: rendered from their fields, or the +# spelling of an id that did not parse (.unparsedAsSpelled()). +# @noRd +.variantTableIds <- function(tab) { + ids <- formatVariantId(tab$chrom, tab$pos, tab$A2, tab$A1) + spelled <- which(str_starts(tab$chrom, fixed(.UNPARSED_CHROM))) + replace(ids, spelled, tab$A2[spelled]) +} + +# The number of variants in a variant table. +# @noRd +.variantTableSize <- function(tab) { + length(tab$pos) +} + +# A variant table as a tibble keyed by every field, for hashing variants +# (vctrs) without rendering ids. +# @noRd +.variantKeyFrame <- function(tab) { + tibble(chrom = tab$chrom, pos = tab$pos, A2 = tab$A2, A1 = tab$A1) +} + +# Variant tables joined, in order. +# @noRd +.bindVariantTables <- function(tables) { + map( + set_names(c("chrom", "pos", "A2", "A1")), + .joinedField, + parts = tables + ) +} + +# Field `field` of each of `parts`, joined into one vector. +# @noRd +.joinedField <- function(field, parts) { + unname(list_c(map(parts, field))) +} + +# The fields of canonical ids, split on ":". +# @noRd +#' @importFrom stringr str_split_fixed +.canonicalVariantTable <- function(ids) { + m <- str_split_fixed(ids, fixed(":"), 4L) + list( + chrom = m[, 1L], + pos = as.integer(m[, 2L]), + A2 = m[, 3L], + A1 = m[, 4L] + ) +} + +# A variant table subset to rows `i`. +# @noRd +.variantTableRows <- function(tab, i) { + map(tab, `[`, i) +} + +# Match variant tables `query` to a `panel`: each query variant's index in the +# panel, or NA. A variant with exactly a panel variant's alleles takes that +# one; the rest are matched allele-aware by the matching engine +# (.matchVariantTables(): ref/alt swap, strand), once per distinct variant. +# Strand-ambiguous pairs are matched, since the callers carry orientation-free +# values such as PIPs. +# @noRd +#' @importFrom vctrs vec_match vec_group_id +.alignTablesToPanel <- function(query, panel) { + qf <- .variantKeyFrame(query) + exact <- vec_match(qf, .variantKeyFrame(panel)) + unmatched <- which(is.na(exact) & !is.na(query$pos)) + if (length(unmatched) == 0L) { + return(exact) + } + group <- vec_group_id(qf[unmatched, , drop = FALSE]) + first <- unmatched[match(seq_len(attr(group, "n")), group)] + m <- .matchVariantTables( + .variantTableRows(query, first), + panel, + removeStrandAmbiguous = FALSE + ) + hit <- replace(rep(NA_integer_, length(first)), m$idxA, m$idxB) + replace(exact, unmatched, hit[as.vector(group)]) +} + +# Match variant ids to a panel of variant ids: each id's index in `panel`, or +# NA. An id spelled exactly as a panel id takes that one; the rest that parse +# are matched by their variants (.alignTablesToPanel()), and an id that does +# not parse (an rsID) only by its spelling. `panelTable` is the panel's +# variant table; as a default argument it is read only when some id is not +# spelled as a panel id, since parsing a genome-wide panel's ids costs +# seconds. +# @noRd +.alignIdsToPanel <- function( + ids, + panel, + panelTable = .idsVariantTable(panel) +) { + exact <- match(ids, panel) + unmatched <- which(is.na(exact)) + if (length(unmatched) == 0L) { + return(exact) + } + rest <- .idsVariantTable(ids[unmatched]) + parsed <- which(!is.na(rest$chrom) & !is.na(rest$pos)) + if (length(parsed) == 0L) { + return(exact) + } + at <- .alignTablesToPanel(.variantTableRows(rest, parsed), panelTable) + replace(exact, unmatched[parsed], at) +} + #' Classify variant type from allele strings #' #' Determines whether each variant is a SNP, insertion, deletion, or diff --git a/Rplots.pdf b/Rplots.pdf deleted file mode 100644 index c11f7f2a..00000000 Binary files a/Rplots.pdf and /dev/null differ diff --git a/_pkgdown.yml b/_pkgdown.yml index ebf5f9e3..69040be7 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -313,6 +313,7 @@ reference: - susieFit - topLoci - traitPosition + - trimFineMappingResult - variantIds - intersectVariants - resolveWeights @@ -735,6 +736,7 @@ reference: - computeSldscAnnotSd - computeSldscMRef - readAnnotations + - fineMappingAnnotations - readSldscTrait - readSldscAnnot - readSldscFrq diff --git a/data/fsusieFineMappingExample.rda b/data/fsusieFineMappingExample.rda index 1ff2bc0e..e68a6440 100644 Binary files a/data/fsusieFineMappingExample.rda and b/data/fsusieFineMappingExample.rda differ diff --git a/data/gwasFineMappingExample.rda b/data/gwasFineMappingExample.rda index 5c7db01a..cc1de8a1 100644 Binary files a/data/gwasFineMappingExample.rda and b/data/gwasFineMappingExample.rda differ diff --git a/data/gwasFineMappingLbfExample.rda b/data/gwasFineMappingLbfExample.rda index 750835e9..8a4c9d61 100644 Binary files a/data/gwasFineMappingLbfExample.rda and b/data/gwasFineMappingLbfExample.rda differ diff --git a/data/mvsusieFineMappingExample.rda b/data/mvsusieFineMappingExample.rda index 80aee8ad..690f5788 100644 Binary files a/data/mvsusieFineMappingExample.rda and b/data/mvsusieFineMappingExample.rda differ diff --git a/data/qtlFineMappingExample.rda b/data/qtlFineMappingExample.rda index b8fa121c..a1ef15a3 100644 Binary files a/data/qtlFineMappingExample.rda and b/data/qtlFineMappingExample.rda differ diff --git a/data/qtlFineMappingLbfExample.rda b/data/qtlFineMappingLbfExample.rda index e58fbf47..691329a6 100644 Binary files a/data/qtlFineMappingLbfExample.rda and b/data/qtlFineMappingLbfExample.rda differ diff --git a/data/qtlFineMappingPairedExample.rda b/data/qtlFineMappingPairedExample.rda index 2c572b00..d7863f37 100644 Binary files a/data/qtlFineMappingPairedExample.rda and b/data/qtlFineMappingPairedExample.rda differ diff --git a/man/FineMappingResultBase-class.Rd b/man/FineMappingResultBase-class.Rd index 9ebb68c8..650e495a 100644 --- a/man/FineMappingResultBase-class.Rd +++ b/man/FineMappingResultBase-class.Rd @@ -25,12 +25,15 @@ pipeline combines share an LD reference.} }} \section{Narrowed rows}{ - Each row records in its \code{fitVariants} column - the ids of the variants its fit was made with (none for a row without a - fit). A row narrowed since -- by \code{endoapply()} or \code{[[<-} -- - keeps its fit as it was, so every reader of the fit warns, with - condition class \code{pecotmrFitCoverage}, when a row holds fewer - variants than its fit describes. The readers are the accessors + A row is built from its fit, holding the fit's + variables in the fit's order, so its fit is read off it by position. A + row narrowed since -- by \code{endoapply()} or \code{[[<-} -- keeps its + fit as it was, and is found in the fit by the names the fit gives its + variables (a narrowed row whose fit names none, such as a trimmed fit, + cannot be read). Every reader of the fit warns, with condition class + \code{pecotmrFitCoverage}, when a row holds fewer variants than its fit + describes. A row replaced by one of the same length is read by + position. The readers are the accessors (\code{susieFit()}, \code{lbf()}, \code{cvResult()}, \code{credibleSetSummary()} and the fSuSiE views), \code{computeCsCorrelation()}, \code{susieResult()}, diff --git a/man/FineMappingRow-class.Rd b/man/FineMappingRow-class.Rd index c5bf877e..43a987d7 100644 --- a/man/FineMappingRow-class.Rd +++ b/man/FineMappingRow-class.Rd @@ -20,10 +20,11 @@ columns are the per-variant \code{topLoci} values.} \item{\code{cvResult}}{Cross-validation payload, or \code{NULL}.} -\item{\code{fitVariants}}{The ids of the variants the stored fit was made with, in -the fit's own order, recorded when the row is built; empty for a row with -no fit. A row narrowed to fewer variants keeps them, which is how reading -the fit can tell it describes more variants than the row now holds.} +\item{\code{derivedColumns}}{The credible-set columns (\code{cs_} and +their \code{_purity} partners) the row does not store because its fit +reproduces them exactly, followed by \code{"method="}, the method +tag of their labels; every view derives them back. Empty when it stores +all it was given.} }} \section{Coercion}{ diff --git a/man/H2Estimate-class.Rd b/man/H2Estimate-class.Rd index ab2dc58c..d9d91f97 100644 --- a/man/H2Estimate-class.Rd +++ b/man/H2Estimate-class.Rd @@ -29,8 +29,8 @@ heritability estimates NULL if unstratified. Two shapes are possible, depending on which route produced the estimate: \describe{ - \item{partitioned}{tau-based enrichment of the baseline annotations - (\code{computeBaselineEnrichment}, \code{.gldscEnrichmentDf}), with + \item{partitioned}{enrichment of the user's baseline annotations + from their partitioned heritabilities \eqn{A'A\tau}, with columns \code{annotation}, \code{tau}, \code{tauSe}, \code{enrichment}, \code{enrichmentSe}, \code{enrichmentP}, \code{propH2}, \code{propSnps}.} diff --git a/man/QtlEnrichmentParam.Rd b/man/QtlEnrichmentParam.Rd index ee7a1e5b..1240ede1 100644 --- a/man/QtlEnrichmentParam.Rd +++ b/man/QtlEnrichmentParam.Rd @@ -16,12 +16,15 @@ QtlEnrichmentParam( ) } \arguments{ -\item{numGwas}{Number of GWAS variants used to estimate \code{piGwas}. -\code{NULL} (default) estimates it from the data, which is biased unless -the outcome PIP vector really is genome-wide.} +\item{numGwas}{The total number of variants the GWAS tested (fastenloc's +\code{-total_variants}), over which \code{piGwas} and \code{piQtl} are +estimated. \code{NULL} (default) uses the number of distinct variants in +the outcome PIP vector and the annotation fits, with a warning; that is +biased unless the outcome PIP vector really is genome-wide.} \item{piQtl}{Per-variant prior of being a causal QTL variant. \code{NULL} -(default) estimates it from the data.} +(default) estimates it as fastenloc does: the annotation fits' summed +PIPs over the variant total (see \code{numGwas}).} \item{lambda}{Shrinkage parameter, shrinking the enrichment estimate towards zero as in ridge regression. \code{0} applies no shrinkage. diff --git a/man/QtlFineMappingResult-class.Rd b/man/QtlFineMappingResult-class.Rd index 55b19291..2dbf5c3e 100644 --- a/man/QtlFineMappingResult-class.Rd +++ b/man/QtlFineMappingResult-class.Rd @@ -13,9 +13,8 @@ S4 collection of fine-mapping fits for one or more QTL Required \code{mcols()} columns: the identity tuple \code{study}, \code{context}, \code{trait} and \code{method}, which is unique, and each row's stored fit \code{susieFit} and cross-validation result -\code{cvResult}. The constructor also records \code{fitVariants}, the -variants each fit was made with. There is no LD-block axis: a trait's fit -is one row wherever its window falls. +\code{cvResult}. There is no LD-block axis: a trait's fit is one row +wherever its window falls. Optional columns \code{jointStudies}, \code{jointContexts}, \code{jointTraits} appear when the collection contains rows produced by a diff --git a/man/computeBaselineEnrichment.Rd b/man/computeBaselineEnrichment.Rd deleted file mode 100644 index 6b880b5a..00000000 --- a/man/computeBaselineEnrichment.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{computeBaselineEnrichment} -\alias{computeBaselineEnrichment} -\title{Compute Baseline Annotation Enrichment Quantities} -\usage{ -computeBaselineEnrichment( - tau, - tauSe, - annotationJackknifeCoefs, - baselineMat, - annotNames, - h2 -) -} -\arguments{ -\item{tau}{Numeric vector of per-annotation regression coefficients.} - -\item{tauSe}{Numeric vector of SE for tau.} - -\item{annotationJackknifeCoefs}{Numeric matrix (nBlocks x nAnnotations) of -jackknife block-level tau values, or NULL.} - -\item{baselineMat}{Numeric matrix (nSnps x nAnnotations).} - -\item{annotNames}{Character vector of annotation names.} - -\item{h2}{Numeric scalar, total estimated h2.} -} -\value{ -A tibble with columns: annotation, tau, tauSe, enrichment, - enrichmentSe, enrichmentP, propH2, propSnps. -} -\description{ -Given tau coefficients and a baseline annotation matrix, compute - the full set of enrichment quantities: propH2, propSnps, enrichment ratio, - enrichment SE (from jackknife or delta method), and p-value. -} -\keyword{internal} diff --git a/man/fineMappingAnnotations.Rd b/man/fineMappingAnnotations.Rd new file mode 100644 index 00000000..869eb7d7 --- /dev/null +++ b/man/fineMappingAnnotations.Rd @@ -0,0 +1,99 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/h2Annotations.R +\name{fineMappingAnnotations} +\alias{fineMappingAnnotations} +\title{Annotations From Fine-Mapping Results} +\usage{ +fineMappingAnnotations( + x, + ldRef, + types = c("maxCpp", "sumPip", "credibleSet", "highPip"), + coverage = 0.95, + minPurity = NULL, + pipThreshold = 0.5, + tier = "candidate" +) +} +\arguments{ +\item{x}{A \code{\link{QtlFineMappingResult}} or +\code{\link{GwasFineMappingResult}}.} + +\item{ldRef}{The \code{\linkS4class{LdStatistic}} the annotations will be +used with.} + +\item{types}{Which annotation types to build; see above. Default all four.} + +\item{coverage}{Credible-set coverage for \code{"credibleSet"}. Default +\code{0.95}.} + +\item{minPurity}{Minimum credible-set purity for \code{"credibleSet"}; +\code{NULL} (default) applies none.} + +\item{pipThreshold}{PIP cutoff for \code{"highPip"}. Default \code{0.5}.} + +\item{tier}{The tier the columns take: \code{"candidate"} (default), so +\code{estimateH2} score-tests each for enrichment over the baseline, or +\code{"baseline"}, to fit them jointly with it.} +} +\value{ +An \code{\linkS4class{AnnotationMatrix}} with one row per variant of + \code{ldRef}. Columns are named + \code{"|||"}, omitting an axis \code{x} + does not have. +} +\description{ +Turn fine-mapping results -- typically molecular QTLs -- into + per-variant annotations over an LD reference's variants, for + \code{\link{estimateH2}} to test for heritability enrichment. Each + (\code{study}, \code{context}, \code{method}) unit of \code{x} pools its + traits (e.g. genes) into one column per requested type: + \describe{ + \item{\code{"maxCpp"}}{A variant's largest PIP over the unit's traits + (continuous; Hormozdiari et al. 2018).} + \item{\code{"sumPip"}}{The sum of its PIPs over the traits: the + expected number of the unit's causal effects it carries + (continuous).} + \item{\code{"credibleSet"}}{1 when it sits in a credible set of any + trait at \code{coverage} (and \code{minPurity}), else 0.} + \item{\code{"highPip"}}{1 when its largest PIP is at least + \code{pipThreshold}, else 0.} + } + + Variants are matched to the reference allele-aware (id format, ref/alt + swap, strand) by their coordinates and alleles, so a reference naming + its variants by rsID matches too; a fine-mapped variant the reference + lacks contributes nothing, and a reference variant no trait fine-mapped + takes 0. A column that comes out all zero -- a unit none of whose + variants are in the reference, or none of whose PIPs reach + \code{pipThreshold} -- is dropped, with a warning. + + The rows follow the reference's variants in its order, as + \code{estimateH2} requires. +} +\examples{ +data(qtlFineMappingExample) +fm <- topLoci(qtlFineMappingExample, signalCutoff = 0) +ref <- LdScore( + ldBlocks = GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(min(GenomicRanges::start(fm)), + max(GenomicRanges::start(fm))) + ), + snpInfo = data.frame( + SNP = S4Vectors::mcols(fm)$variant_id, + CHR = "chr22", + BP = GenomicRanges::start(fm), + A1 = S4Vectors::mcols(fm)$A1, + A2 = S4Vectors::mcols(fm)$A2 + ), + nSamples = 1000L, + inSample = FALSE, + ldScores = matrix(1, length(fm), 1, dimnames = list(NULL, "base_l2")), + ldScoreWeights = rep(1, length(fm)) +) +annot <- fineMappingAnnotations( + qtlFineMappingExample, ref, + pipThreshold = 0.1 +) +colnames(annot) +} diff --git a/man/qtlEnrichment.Rd b/man/qtlEnrichment.Rd index a9c9b1bd..7465fb56 100644 --- a/man/qtlEnrichment.Rd +++ b/man/qtlEnrichment.Rd @@ -21,19 +21,23 @@ qtlEnrichment( ) } \arguments{ -\item{gwasPip}{This is a vector of GWAS PIP, genome-wide.} +\item{gwasPip}{A named vector of GWAS PIPs, one per variant, ideally +genome-wide.} -\item{susieQtlRegions}{This is a list of SuSiE fitted objects per QTL unit -analyzed} +\item{susieQtlRegions}{A named list of SuSiE fits, one per QTL unit +analyzed (e.g. a gene), each with \code{alpha}, a named \code{pip} and +\code{prior_variance}.} -\item{numGwas}{This parameter is highly important if GWAS input does not -contain all SNPs interrogated (e.g., in some cases, only fine-mapped geomic -regions are included). Then users must pick a value of total_variants and -estimate piGwas beforehand by: sum(gwasPip$pip)/numGwas. If numGwas is -null, piGwas would be sum(gwasPip$pip)/total_variants.} +\item{numGwas}{The total number of variants the GWAS tested (fastenloc's +\code{-total_variants}). It matters whenever \code{gwasPip} does not +carry every variant tested, e.g. when it covers only fine-mapped blocks. +\code{NULL} (default) uses the number of distinct variants in +\code{gwasPip} and the QTL fits, with a warning; a value below that number +is raised to it.} -\item{piQtl}{This parameter can be safely left to default if your input QTL -data has enough regions to estimate it.} +\item{piQtl}{Per-variant prior of being a causal QTL variant. \code{NULL} +(default) estimates it as fastenloc does, from the fits' summed PIPs over +the variant total.} \item{lambda}{Similar to the shrinkage parameter used in ridge regression. It takes any non-negative value and shrinks the enrichment estimate towards 0. @@ -55,12 +59,13 @@ thread. Default \code{SerialParam()}.} \item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} -\item{alignNames}{Logical; when TRUE (default) QTL pip names are aligned to -the GWAS variant-naming convention via \code{matchVariants}. Set FALSE when -the caller has already aligned them (e.g. \code{qtlEnrichmentPipeline} -aligns each QTL tuple once against the union GWAS panel rather than -re-aligning per GWAS study); only the cheap per-study unmatched set is then -recomputed, skipping the costly \code{harmonizeAlleles} pass.} +\item{alignNames}{Logical; when TRUE (default) a QTL pip name not spelled +as any \code{gwasPip} name is matched, allele-aware (id format, ref/alt +swap, strand), to the GWAS variants at its position, and takes the name +of the one it matches. Set FALSE when the caller has already aligned them +(e.g. \code{qtlEnrichmentPipeline} aligns each QTL tuple once against +the union GWAS panel rather than re-aligning per GWAS study); the names +are then matched to \code{gwasPip} exactly as given.} \item{seed}{Integer or \code{NULL}. Base random seed for the multiple- imputation sampler; each imputation round derives its own seed from it, so @@ -73,10 +78,17 @@ A named list of enrichment parameter estimates, carrying the \code{sd (intercept)}, \code{Enrichment (no shrinkage)}, \code{Enrichment (w/ shrinkage)}, \code{sd (no shrinkage)}, \code{sd (w/ shrinkage)}, \code{Alternative (coloc) p1} / \code{p2} / - \code{p12} and \code{Effective MI rounds} -- plus - \code{unused_xqtl_variants}, the QTL variants of each region that no GWAS - variant matched. The names are the original fastenloc's; - \code{\link{qtlEnrichmentPipeline}} is what renames them to a tidy table. + \code{p12} and \code{Effective MI rounds} -- plus diagnostics: + \code{Missing proportion per MI round}, the share of each round's sampled + QTL variants that \code{gwasPip} does not carry (they enter with GWAS + PIP 0); + \code{EM converged per MI round}; \code{EM iterations per MI round}, + how many EM iterations each round took; \code{Null QTL fits}, the number of + fits with no effect of positive prior variance, which contribute no + sampled variants; and \code{unused_xqtl_variants}, the QTL variants of + each region that no GWAS variant matched. The estimate names are the + original fastenloc's; \code{\link{qtlEnrichmentPipeline}} is what renames + them to a tidy table. } \description{ Largely follows from fastenloc @@ -93,38 +105,50 @@ Largely follows from fastenloc \details{ Uses output of \code{\link[susieR]{susie}} from the \code{susieR} package. + + As in fastenloc, the variants the estimate is taken over are every + variant of \code{gwasPip} plus every QTL variant \code{gwasPip} does not + carry. The latter have GWAS PIP 0, so each one sampled in an imputation + round counts as a QTL variant that is not causal for the GWAS trait. The + variant total is \code{numGwas}, raised to the number of those variants + when smaller; \code{piGwas} is \code{sum(gwasPip)} over it and, unless + supplied, \code{piQtl} is the fits' summed PIPs over it. The intercept is + derived from \code{piGwas}, \code{piQtl} and the unshrunk enrichment, + and the coloc priors from that intercept and the shrunk enrichment, both + as fastenloc does. One difference remains: fastenloc's EM keeps the + previous iteration's intercept at convergence where this one updates it, + which changes only \code{sd (intercept)}. } \examples{ - -# Simulate fake data for gwasPip -nGwasPip <- 1000 -gwasPip <- runif(nGwasPip) -names(gwasPip) <- paste0("snp", 1:nGwasPip) -# Simulate fake data for a single SuSiEFit object -simulateSusiefit <- function(n, p) { - pip <- runif(n) - names(pip) <- paste0("snp", 1:n) - alpha <- t(matrix(runif(n * p), nrow = n)) - alpha <- t(apply(alpha, 1, function(row) row / sum(row))) +set.seed(1) +# GWAS PIPs for 2000 variants of a GWAS that tested one million: mostly +# near zero, with two strong signals. +ids <- sprintf("chr1:\%d:A:G", 1000 * seq_len(2000)) +gwasPip <- stats::setNames(stats::rbeta(2000, 0.05, 100), ids) +gwasPip[c(300, 1200)] <- c(0.95, 0.6) +# A SuSiE-like fit per gene: two single effects over the gene's variants, +# each concentrated on a few of them. +simulateFit <- function(idx, hits) { + alpha <- matrix(1e-4, length(hits), length(idx)) + alpha[cbind(seq_along(hits), hits)] <- 1 + alpha <- alpha / rowSums(alpha) list( - pip = pip, alpha = alpha, - prior_variance = runif(p) + pip = stats::setNames(1 - apply(1 - alpha, 2, prod), ids[idx]), + prior_variance = c(0.4, 0.1) ) } -# Simulate multiple SuSiEFit objects -nSusieFits <- 2 -susieFits <- replicate( - nSusieFits, simulateSusiefit(nGwasPip, 10), simplify = FALSE) -# Add these fits to a list, providing names to each element -names(susieFits) <- paste0("fit", seq_along(susieFits)) -# Set other parameters -impN <- 10 -lambda <- 1 -library(pecotmr) +susieFits <- list( + gene1 = simulateFit(251:350, c(50, 10)), + gene2 = simulateFit(1151:1250, c(50, 80)), + gene3 = simulateFit(1601:1700, c(20, 70)) +) en <- qtlEnrichment( - gwasPip, susieFits, lambda = lambda, impN = impN, - BPPARAM = BiocParallel::SerialParam()) + gwasPip, susieFits, + numGwas = 1e6, impN = 10, seed = 1, + BPPARAM = BiocParallel::SerialParam(), verbose = FALSE +) +en[["Enrichment (w/ shrinkage)"]] } \seealso{ diff --git a/man/qtlEnrichmentPipeline.Rd b/man/qtlEnrichmentPipeline.Rd index 15cc4ca5..e281bd35 100644 --- a/man/qtlEnrichmentPipeline.Rd +++ b/man/qtlEnrichmentPipeline.Rd @@ -10,7 +10,8 @@ qtlEnrichmentPipeline( qtlEnrichmentParam = QtlEnrichmentParam(), BPPARAM = SerialParam(), seed = NULL, - verbose = TRUE + verbose = TRUE, + duplicatePips = c("max", "error", "blockEnd") ) } \arguments{ @@ -29,10 +30,21 @@ checked.} its workers. Default \code{SerialParam()}.} \item{seed}{Integer or \code{NULL}. Base random seed forwarded to -\code{\link{qtlEnrichment}} for reproducible multiple imputation. -\code{NULL} (default) draws a nondeterministic seed.} +\code{\link{qtlEnrichment}} for reproducible multiple imputation; every +(outcome, annotation) pair is run with this same seed. \code{NULL} +(default) draws a nondeterministic seed per pair.} \item{verbose}{Logical. Print progress messages. Default \code{TRUE}.} + +\item{duplicatePips}{How to resolve a variant to which the outcome's LD +blocks give different PIPs, as adjacent blocks sharing a boundary variant +do when each block's fit gives it its own. Copies that agree are always +merged. \code{"max"} (default) keeps the largest PIP. \code{"blockEnd"} +keeps the copy from the block whose window was given (see +\code{\link{genomicRegion}}) and ends at the variant --- the upstream of +two blocks sharing it --- and errors when no single block qualifies. +\code{"error"} refuses. fastenloc does none of these: it keeps the last +copy's PIP but counts every copy towards the GWAS prior.} } \value{ A tibble with one row per (outcome fit, annotation unit) pair. diff --git a/man/trimFineMappingResult.Rd b/man/trimFineMappingResult.Rd new file mode 100644 index 00000000..ae255bd7 --- /dev/null +++ b/man/trimFineMappingResult.Rd @@ -0,0 +1,58 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllClasses.R +\name{trimFineMappingResult} +\alias{trimFineMappingResult} +\title{Trim A Fine-Mapping Collection To What Its Role Reads} +\usage{ +trimFineMappingResult(x, role = NULL) +} +\arguments{ +\item{x}{A \code{\link{GwasFineMappingResult}} or +\code{\link{QtlFineMappingResult}}.} + +\item{role}{\code{"outcome"} or \code{"annotation"}. \code{NULL} (default) +picks by class: \code{"outcome"} for a \code{GwasFineMappingResult}, +\code{"annotation"} for a \code{QtlFineMappingResult}.} +} +\value{ +\code{x}, trimmed. +} +\description{ +Keep, of each row's fit, only what a fine-mapping collection + is read for in its \code{role}, so a genome-wide collection fits in + memory. Nothing is sampled or summarized ahead of time: a trimmed + collection gives the same enrichment estimates as the untrimmed one, and + can still be resampled. + + \describe{ + \item{\code{"outcome"}}{The side whose PIPs are scanned, as in + \code{\link{qtlEnrichmentPipeline}}'s \code{gwasFineMappingResult}: + each fit keeps its \code{pip} and its credible sets (\code{sets}, + \code{sets_secondary}).} + \item{\code{"annotation"}}{The side whose single effects are sampled, + as in \code{qtlFineMappingResult}: each fit also keeps \code{alpha} + and the prior variances \code{V} of its effects of positive prior + variance -- the only ones the enrichment samples -- with rows and + entries named by effect id (\code{"L"}). A fit with no such + effect keeps a zero-row \code{alpha}.} + } + + Each row's per-variant columns are cut to the identity columns, the + PIPs and the credible-set columns, and those two are stored only where + the trimmed fit cannot give them back. The posterior summaries, marginal + statistics and per-fit metadata columns go, so \code{\link{topLoci}} of a + trimmed collection reports PIPs and credible sets only. The + cross-validation results go as well, so a trimmed collection cannot feed + \code{\link{twasWeightsPipeline}}. Identity columns, names, the genome + build, LD references and \code{metadata()} are kept. Trimming a trimmed + collection changes nothing. +} +\examples{ +data(qtlFineMappingExample) +trimmed <- trimFineMappingResult(qtlFineMappingExample) +names(susieFit(trimmed)) +c( + before = utils::object.size(qtlFineMappingExample), + after = utils::object.size(trimmed) +) +} diff --git a/man/updateObject-methods.Rd b/man/updateObject-methods.Rd index d6c29fb8..ecda74c6 100644 --- a/man/updateObject-methods.Rd +++ b/man/updateObject-methods.Rd @@ -83,9 +83,11 @@ Bring an object saved by an earlier version of pecotmr up to both in one \code{qcInfo} record have it split between the two. Their genome build is in \code{seqinfo()}; ones saved with it in a \code{genome} slot have it moved there. - \item Fine-mapping results and TWAS weights record the variants each - row was fitted on in a \code{fitVariants} column; ones saved without - it have it filled in from their fits. + \item TWAS weights record the variants each row was fitted on in a + \code{fitVariants} column; ones saved without it have it filled in + from their fits. Fine-mapping results no longer record them (a row's + variants are its fit's variables); ones saved with the column have + it dropped. \item A \code{CtwasResult} holds one element per region; one saved as a table of whole runs is rebuilt. \item A \code{QtlDataset} no longer stores run settings (genotype diff --git a/src/cpp11.cpp b/src/cpp11.cpp index e2144631..0a1cccba 100644 --- a/src/cpp11.cpp +++ b/src/cpp11.cpp @@ -69,10 +69,10 @@ extern "C" SEXP _pecotmr_prsCsFactorCpp(SEXP a, SEXP b, SEXP phi, SEXP bhat, SEX END_CPP11 } // qtl_enrichment.cpp -cpp11::writable::list qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); -extern "C" SEXP _pecotmr_qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { +cpp11::writable::list qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, double piGwas, double piQtl, double totalVariants, int ImpN, double shrinkageLambda, bool doubleShrinkage, bool besselCorrection, int numThreads, cpp11::sexp seed); +extern "C" SEXP _pecotmr_qtlEnrichmentCpp(SEXP rGwasPip, SEXP rQtlSusieFit, SEXP piGwas, SEXP piQtl, SEXP totalVariants, SEXP ImpN, SEXP shrinkageLambda, SEXP doubleShrinkage, SEXP besselCorrection, SEXP numThreads, SEXP seed) { BEGIN_CPP11 - return cpp11::as_sexp(qtlEnrichmentCpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); + return cpp11::as_sexp(qtlEnrichmentCpp(cpp11::as_cpp>(rGwasPip), cpp11::as_cpp>(rQtlSusieFit), cpp11::as_cpp>(piGwas), cpp11::as_cpp>(piQtl), cpp11::as_cpp>(totalVariants), cpp11::as_cpp>(ImpN), cpp11::as_cpp>(shrinkageLambda), cpp11::as_cpp>(doubleShrinkage), cpp11::as_cpp>(besselCorrection), cpp11::as_cpp>(numThreads), cpp11::as_cpp>(seed))); END_CPP11 } // sdpr.cpp @@ -108,7 +108,7 @@ static const R_CallMethodDef CallEntries[] = { {"_pecotmr_penalizedRssFactorCpp", (DL_FUNC) &_pecotmr_penalizedRssFactorCpp, 12}, {"_pecotmr_prsCsCpp", (DL_FUNC) &_pecotmr_prsCsCpp, 12}, {"_pecotmr_prsCsFactorCpp", (DL_FUNC) &_pecotmr_prsCsFactorCpp, 12}, - {"_pecotmr_qtlEnrichmentCpp", (DL_FUNC) &_pecotmr_qtlEnrichmentCpp, 10}, + {"_pecotmr_qtlEnrichmentCpp", (DL_FUNC) &_pecotmr_qtlEnrichmentCpp, 11}, {"_pecotmr_sdprCpp", (DL_FUNC) &_pecotmr_sdprCpp, 17}, {"_pecotmr_sdprFactorCpp", (DL_FUNC) &_pecotmr_sdprFactorCpp, 17}, {"_pecotmr_vcfGtDosageCpp", (DL_FUNC) &_pecotmr_vcfGtDosageCpp, 2}, diff --git a/src/qtl_enrichment.cpp b/src/qtl_enrichment.cpp index 6fad0cce..303d89eb 100644 --- a/src/qtl_enrichment.cpp +++ b/src/qtl_enrichment.cpp @@ -1,32 +1,34 @@ #include "qtl_enrichment.h" +// `rGwasPip` holds the GWAS PIP values; `rQtlSusieFit` is a list of fits, each +// with `alpha`, `prior_variance` and integer `codes` that index its variables +// into `rGwasPip` (negative for variants it does not carry). `totalVariants` +// is the variant count the EM remainder is taken over. [[cpp11::register]] cpp11::writable::list qtlEnrichmentCpp( SEXP rGwasPip, SEXP rQtlSusieFit, - double piGwas = 0, double piQtl = 0, + double piGwas, double piQtl, double totalVariants, int ImpN = 25, double shrinkageLambda = 1.0, bool doubleShrinkage = false, bool besselCorrection = true, int numThreads = 1, cpp11::sexp seed = R_NilValue) { - // Convert rGwasPip to C++ type - doubles gwas_pip_vec(rGwasPip); - std::vector gwas_pip = cpp11::as_cpp>(gwas_pip_vec); - cpp11::strings pip_names(gwas_pip_vec.attr("names")); - std::vector gwas_pip_names; - gwas_pip_names.reserve(pip_names.size()); - for (int i = 0; i < pip_names.size(); ++i) { - gwas_pip_names.push_back(std::string(pip_names[i])); - } + std::vector gwas_pip = cpp11::as_cpp>(doubles(rGwasPip)); + const int n_gwas = static_cast(gwas_pip.size()); - // Convert rQtlSusieFit to C++ type + // Convert rQtlSusieFit to C++ type, refusing a code that points past the + // GWAS vector, since a sampled variant's code indexes it directly. list susie_fit_list(rQtlSusieFit); std::vector susie_fits; - + susie_fits.reserve(susie_fit_list.size()); for (int i = 0; i < susie_fit_list.size(); ++i) { - SuSiEFit susie_fit(susie_fit_list[i]); - susie_fits.push_back(susie_fit); + susie_fits.emplace_back(susie_fit_list[i]); + for (int code : susie_fits.back().codes) { + if (code >= n_gwas) { + cpp11::stop("A variant code points past the end of the GWAS PIP vector."); + } + } } // Resolve the base seed: use the user-provided value, otherwise a @@ -38,16 +40,31 @@ cpp11::writable::list qtlEnrichmentCpp( base_seed = std::random_device{}(); } - std::map output = qtl_enrichment_workhorse(susie_fits, gwas_pip, gwas_pip_names, piGwas, piQtl, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, base_seed); + EnrichmentOutput output = qtl_enrichment_workhorse(susie_fits, gwas_pip, piGwas, piQtl, totalVariants, ImpN, shrinkageLambda, doubleShrinkage, besselCorrection, numThreads, base_seed); - // Convert std::map to list - using namespace cpp11::literals; + // The estimates (std::map order), then the per-round diagnostics. writable::list output_list; writable::strings names; - for (auto const& element : output) { + for (auto const& element : output.estimates) { output_list.push_back(cpp11::as_sexp(element.second)); names.push_back(element.first); } + writable::doubles missing(ImpN); + writable::logicals converged(ImpN); + writable::integers iterations(ImpN); + for (int k = 0; k < ImpN; ++k) { + missing[k] = output.missing_proportion[k]; + converged[k] = output.em_converged[k] != 0; + iterations[k] = output.em_iterations[k]; + } + output_list.push_back(missing); + names.push_back("Missing proportion per MI round"); + output_list.push_back(converged); + names.push_back("EM converged per MI round"); + output_list.push_back(iterations); + names.push_back("EM iterations per MI round"); + output_list.push_back(cpp11::as_sexp(output.invalid_rounds)); + names.push_back("Invalid MI rounds"); output_list.attr("names") = names; return output_list; diff --git a/src/qtl_enrichment.h b/src/qtl_enrichment.h index 88b4e8cb..3abb9920 100644 --- a/src/qtl_enrichment.h +++ b/src/qtl_enrichment.h @@ -10,53 +10,52 @@ #include #include #include +#include #include +#include using namespace cpp11; using namespace arma; +// One QTL region's fit as the R wrapper hands it over: alpha (effects x +// variables), the effects' prior variances, and each variable's integer code, +// which is the 0-based index of the same variant in the GWAS PIP vector, or a +// negative id for a variant the GWAS vector does not carry. Coding the +// variables in R keeps variant-name strings out of the kernel. Only effects +// with prior variance > 0 are kept; a fit with none of them is a null fit, +// which samples nothing and draws nothing from the random stream. The R +// wrapper validates the fit first; the checks here only guard the kernel. class SuSiEFit { public: -std::vector variable_names; +std::vector codes; mat alpha; -std::vector prior_variance; SuSiEFit(SEXP r_susie_fit) { list susie_fit(r_susie_fit); - doubles pip_vec(susie_fit["pip"]); - // Get names from the pip vector - cpp11::strings pip_names(pip_vec.attr("names")); - variable_names.reserve(pip_names.size()); - for (int i = 0; i < pip_names.size(); ++i) { - variable_names.push_back(std::string(pip_names[i])); - } - alpha = as_Mat(doubles_matrix<>(susie_fit["alpha"])); - prior_variance = cpp11::as_cpp>(susie_fit["prior_variance"]); + std::vector prior_variance = cpp11::as_cpp>(susie_fit["prior_variance"]); + codes = cpp11::as_cpp>(susie_fit["codes"]); if (alpha.n_rows != prior_variance.size()) { cpp11::stop("The number of rows in alpha must match the length of prior_variance."); } - - // Check if all elements in prior_variance are not greater than 0 - if (std::all_of(prior_variance.begin(), prior_variance.end(), [](double x) { - return x <= 0; - })) { - cpp11::stop("At least one element in prior_variance must be greater than 0."); + if (alpha.n_cols != codes.size()) { + cpp11::stop("The number of columns in alpha must match the number of variant codes."); } - // Filter out rows with prior_variance = 0 std::vector valid_rows; for (size_t i = 0; i < prior_variance.size(); ++i) { if (prior_variance[i] > 0) { valid_rows.push_back(i); } } - alpha = alpha.rows(uvec(valid_rows)); - prior_variance.erase(std::remove(prior_variance.begin(), prior_variance.end(), 0), prior_variance.end()); + if (valid_rows.empty()) { + alpha.set_size(0, alpha.n_cols); + } else if (valid_rows.size() < alpha.n_rows) { + alpha = alpha.rows(uvec(valid_rows)); + } - // Add a check to make sure each row of alpha sums to 1 for (uword i = 0; i < alpha.n_rows; ++i) { double row_sum = sum(alpha.row(i)); if (std::abs(row_sum - 1.0) > 1e-6) { @@ -66,18 +65,19 @@ SuSiEFit(SEXP r_susie_fit) { } } -std::vector impute_qtn(std::mt19937 &gen) const { - std::vector qtn_names; +// One sampled variable per kept effect, returned as its code. +std::vector impute_qtn(std::mt19937 &gen) const { + std::vector qtn_codes; for (uword i = 0; i < alpha.n_rows; ++i) { arma::rowvec row_i = alpha.row(i); std::vector alpha_row(row_i.begin(), row_i.end()); std::discrete_distribution<> dist(alpha_row.begin(), alpha_row.end()); int random_index = dist(gen); - qtn_names.push_back(variable_names[random_index]); + qtn_codes.push_back(codes[random_index]); } - return qtn_names; + return qtn_codes; } }; @@ -131,12 +131,68 @@ std::vector filter_outlier_indices( return kept; } -std::vector run_EM( - const std::vector &gwas_pip, - const std::vector & annotation_vector, +// One imputation round's EM estimates. Runs on OpenMP worker threads, so it +// neither prints nor raises; whether it converged, and whether the variant +// total left the (not QTL, not causal) cell positive, are returned instead. +struct EMResult { + double a0; + double a1; + double var0; + double var1; + bool converged; + bool valid; + int iterations; +}; + +// The GWAS variants the EM reads, prepared once for every round: the +// variants of non-zero PIP, each with its prior odds term +// (pip / (1 - pip)) / r_null, computed exactly as the EM loop used to compute +// it; and, for every GWAS variant, its place among them (-1 for a PIP of 0). +// A PIP of 0 has posterior 0 under either prior, so such a variant adds +// exactly one count to its annotation's (not causal) cell whatever the +// priors: the EM adds those counts once per iteration instead of visiting +// each of them. +struct GwasOdds { + std::vector odds; + std::vector place; + double n_zero; +}; + +GwasOdds prepare_gwas_odds(const std::vector &gwas_pip, double pi_gwas) +{ + double r_null = pi_gwas / (1 - pi_gwas); + GwasOdds g; + g.place.assign(gwas_pip.size(), -1); + for (size_t i = 0; i < gwas_pip.size(); i++) { + double val = gwas_pip[i]; + if (val == 0) { + continue; + } + if (val == 1) + val = 1 - 1e-8; + // posterior ratio over the null prior odds: the marginal likelihood + val = val / (1 - val); + g.place[i] = static_cast(g.odds.size()); + g.odds.push_back(val / r_null); + } + g.n_zero = static_cast(gwas_pip.size() - g.odds.size()); + return g; +} + +// `annotated` flags which of the non-zero-PIP variants (GwasOdds::odds) this +// round's QTL sample annotates, and `zero_annotated` how many PIP-0 variants +// it annotates. `qtl_only_sampled` counts this round's distinct sampled QTL +// variants that the GWAS PIP vector does not carry. As in fastenloc, where +// they are part of the SNP universe with GWAS PIP 0, each is a (QTL, not +// causal) variant. +EMResult run_EM( + const GwasOdds & gwas, + const std::vector & annotated, + double zero_annotated, double pi_gwas, double pi_qtl, double total_snp, + double qtl_only_sampled, int max_iter = 1000, double a1_tol = 0.01) { @@ -146,8 +202,9 @@ std::vector run_EM( double var1 = 0; double r0, r1; r0 = r1 = exp(a0); - double r_null = pi_gwas / (1 - pi_gwas); int iter = 0; + const size_t m = gwas.odds.size(); + const double zero_unannotated = gwas.n_zero - zero_annotated; while (true) { iter++; @@ -158,94 +215,99 @@ std::vector run_EM( double e1g0 = pseudo_count * (1 - pi_gwas) * pi_qtl; double e1g1 = pseudo_count * pi_gwas * pi_qtl; - for (size_t i = 0; i < gwas_pip.size(); i++) { - double val = gwas_pip[i]; - if (val == 1) - val = 1 - 1e-8; - // posterior ratio - val = val / (1 - val); - // val/r_null is marginal likelihood/bayes factor - if (annotation_vector[i] == 0) { - val = r0 * (val / r_null); + for (size_t j = 0; j < m; j++) { + if (!annotated[j]) { + double val = r0 * gwas.odds[j]; // updated posterior with current prior given eqtl = 0 val = val / (1 + val); e0g1 += val; e0g0 += 1 - val; - } - - if (annotation_vector[i] == 1) { - val = r1 * (val / r_null); + } else { + double val = r1 * gwas.odds[j]; // updated posterior with current prior given eqtl = 1 val = val / (1 + val); e1g1 += val; e1g0 += 1 - val; } } + // The PIP-0 variants: one (not causal) count each. + e0g0 += zero_unannotated; + e1g0 += zero_annotated; + + // A GWAS PIP of 0 has posterior 0 under either prior, so each sampled + // QTL-only variant adds exactly one (QTL, not causal) count. + e1g0 += qtl_only_sampled; e0g0 += total_snp - (e0g0 + e0g1 + e1g0 + e1g1); + if (!(e0g0 > 0)) { + double nan = std::numeric_limits::quiet_NaN(); + return EMResult{nan, nan, nan, nan, false, false, iter}; + } double a1_new = log(e1g1 * e0g0 / (e1g0 * e0g1)); if (fabs(a1_new - a1) < a1_tol || iter >= max_iter) { + bool converged = fabs(a1_new - a1) < a1_tol; a1 = a1_new; a0 = log(e0g1 / e0g0); var1 = (1.0 / e0g0 + 1.0 / e1g0 + 1.0 / e1g1 + 1.0 / e0g1); var0 = (1.0 / e0g1 + 1.0 / e0g0); - break; + return EMResult{a0, a1, var0, var1, converged, true, iter}; } a1 = a1_new; a0 = log(e0g1 / e0g0); r0 = exp(a0); r1 = exp(a0 + a1); - - if (iter % 100 == 0) { - Rprintf("EM Iteration %d: a0 = %g, a1 = %g\n", iter, a0, a1); - } - } - if (iter == max_iter) { - Rprintf("WARNING: EM algorithm did not converge after %d iterations!\n", iter); } - - std::vector av; - av.push_back(a0); - av.push_back(a1); - av.push_back(var0); - av.push_back(var1); - - return av; } -std::map qtl_enrichment_workhorse( - const std::vector & qtl_susie_fits, - const std::vector & gwas_pip, - const std::vector &gwas_variable_names, - double pi_gwas, - double pi_qtl, - int ImpN, - double shrinkage_lambda, - bool double_shrinkage = false, - bool bessel_correction = true, - int num_threads = 4, - unsigned int base_seed = 0) +// The estimates, plus per-round diagnostics the R wrapper reports: the +// proportion of sampled QTL variants absent from the GWAS PIP vector, whether +// the round's EM converged, and how many rounds the variant total was too +// small for. +struct EnrichmentOutput { + std::map estimates; + std::vector missing_proportion; + std::vector em_converged; + std::vector em_iterations; + int invalid_rounds; +}; + +EnrichmentOutput qtl_enrichment_workhorse( + const std::vector &qtl_susie_fits, + const std::vector & gwas_pip, + double pi_gwas, + double pi_qtl, + double total_snp, + int ImpN, + double shrinkage_lambda, + bool double_shrinkage = false, + bool bessel_correction = true, + int num_threads = 4, + unsigned int base_seed = 0) { std::vector a0_vec(ImpN, 0.0); std::vector v0_vec(ImpN, 0.0); std::vector a1_vec(ImpN, 0.0); std::vector v1_vec(ImpN, 0.0); - - std::map gwas_variant_index; - - for (size_t i = 0; i < gwas_variable_names.size(); ++i) { - gwas_variant_index[gwas_variable_names[i]] = i; + std::vector missing_proportion(ImpN, 0.0); + std::vector em_converged(ImpN, 0); + std::vector em_valid(ImpN, 0); + std::vector em_iterations(ImpN, 0); + const GwasOdds gwas = prepare_gwas_odds(gwas_pip, pi_gwas); + + // QTL-only variants carry the codes -1 .. -n_qtl_only. + int n_qtl_only = 0; + for (const auto &fit : qtl_susie_fits) { + for (int code : fit.codes) { + n_qtl_only = std::max(n_qtl_only, -code); + } } - // pi_gwas = sum(gwas_pip) / total_snp - double total_snp = std::accumulate(gwas_pip.begin(), gwas_pip.end(), 0.0) / pi_gwas; - - Rprintf("Fine-mapped GWAS and QTL data loaded successfully for enrichment analysis!\n"); - + // Each round writes only its own slot of the vectors above, so the loop + // needs no critical section, and nothing in it prints or raises. #pragma omp parallel for num_threads(num_threads) for (int k = 0; k < ImpN; k++) { // Per-round RNG seeded deterministically from the base seed plus the @@ -253,38 +315,58 @@ std::map qtl_enrichment_workhorse( // regardless of which thread runs this round. std::mt19937 gen(base_seed + static_cast(k)); - // Use QTL to annotate GWAS variants - std::vector annotation_vector(gwas_pip.size(), 0); + // Use QTL to annotate GWAS variants; a sampled variant the GWAS vector + // does not carry is counted once, however many fits sampled it. + std::vector annotated(gwas.odds.size(), 0); + std::vector zero_seen; + std::vector qtl_only_seen(n_qtl_only, 0); + int qtl_only_sampled = 0; + int zero_annotated = 0; int missing_qtl_count = 0; int total_qtl_count = 0; for (size_t i = 0; i < qtl_susie_fits.size(); i++) { - std::vector variants = qtl_susie_fits[i].impute_qtn(gen); - for (const auto &variant : variants) { - auto it = gwas_variant_index.find(variant); - if (it != gwas_variant_index.end()) { - annotation_vector[it->second] = 1; + std::vector qtn_codes = qtl_susie_fits[i].impute_qtn(gen); + for (int code : qtn_codes) { + if (code >= 0) { + int at = gwas.place[code]; + if (at >= 0) { + annotated[at] = 1; + } else { + // A PIP-0 variant, counted once however many fits + // sampled it. + if (zero_seen.empty()) { + zero_seen.assign(gwas_pip.size(), 0); + } + if (!zero_seen[code]) { + zero_seen[code] = 1; + ++zero_annotated; + } + } } else { ++missing_qtl_count; + char &seen = qtl_only_seen[-code - 1]; + if (!seen) { + seen = 1; + ++qtl_only_sampled; + } } } - total_qtl_count += variants.size(); - } - double missing_variant_proportion = static_cast(missing_qtl_count) / total_qtl_count; - std::vector rst = run_EM(gwas_pip, annotation_vector, pi_gwas, pi_qtl, total_snp); - - #pragma omp critical - { - a0_vec[k] = rst[0]; - a1_vec[k] = rst[1]; - v0_vec[k] = rst[2]; - v1_vec[k] = rst[3]; - Rprintf("Proportion of xQTL missing from GWAS variants: %g in MI round %d\n", - missing_variant_proportion, k); + total_qtl_count += qtn_codes.size(); } + missing_proportion[k] = total_qtl_count > 0 + ? static_cast(missing_qtl_count) / total_qtl_count + : std::numeric_limits::quiet_NaN(); + EMResult rst = run_EM(gwas, annotated, static_cast(zero_annotated), pi_gwas, pi_qtl, total_snp, static_cast(qtl_only_sampled)); + a0_vec[k] = rst.a0; + a1_vec[k] = rst.a1; + v0_vec[k] = rst.var0; + v1_vec[k] = rst.var1; + em_converged[k] = rst.converged ? 1 : 0; + em_valid[k] = rst.valid ? 1 : 0; + em_iterations[k] = rst.iterations; } - - Rprintf("EM updates completed!\n"); + int invalid_rounds = ImpN - std::accumulate(em_valid.begin(), em_valid.end(), 0); // Apply outlier filtering if shrinkage is specified. // Use index-based filtering to keep all four vectors aligned. @@ -292,10 +374,6 @@ std::map qtl_enrichment_workhorse( std::vector kept_indices; if (pv > 0) { kept_indices = filter_outlier_indices(a1_vec, v1_vec, pv, bessel_correction); - if (kept_indices.size() < static_cast(ImpN)) { - Rprintf("Outlier filtering removed %d MI round(s)\n", - ImpN - static_cast(kept_indices.size())); - } } else { kept_indices.resize(ImpN); std::iota(kept_indices.begin(), kept_indices.end(), 0); @@ -381,7 +459,9 @@ std::map qtl_enrichment_workhorse( } } - a0_est = log(pi_gwas / (1 + pi_qtl * exp(a1_est) - pi_qtl - pi_gwas)); + // The intercept matches piGwas through the unshrunk enrichment, as in + // fastenloc; the coloc priors below then pair it with the shrunk one. + a0_est = log(pi_gwas / (1 + pi_qtl * exp(a1_est_ns) - pi_qtl - pi_gwas)); double pi1_ne = exp(a0_est) / (1 + exp(a0_est)); double pi1_e = exp(a0_est + a1_est) / (1 + exp(a0_est + a1_est)); @@ -403,7 +483,7 @@ std::map qtl_enrichment_workhorse( output_map["Alternative (coloc) p12"] = p12; output_map["Effective MI rounds"] = static_cast(m); - return output_map; + return EnrichmentOutput{output_map, missing_proportion, em_converged, em_iterations, invalid_rounds}; } #endif // QTL_ENRICHMENT_HPP diff --git a/tests/testthat/helper-fineMapping.R b/tests/testthat/helper-fineMapping.R index 8f9956cb..0a0ac22c 100644 --- a/tests/testthat/helper-fineMapping.R +++ b/tests/testthat/helper-fineMapping.R @@ -144,3 +144,84 @@ delayedAssign(".twcvFixture", suppressMessages(.twcv_foldFits())) } fit } + +# ---- The bundled fine-mapping examples, rebuilt row by row ------------- +# Shared by the row and trimming tests: each example row goes back through +# FineMappingRow(), so a test can compare a collection built today with one +# saved by an earlier pecotmr, or rebuild a row with its fit edited. + +# The bundled fine-mapping examples, by name. +.fmExampleNames <- function() { + c( + "qtlFineMappingExample", + "qtlFineMappingLbfExample", + "qtlFineMappingPairedExample", + "gwasFineMappingExample", + "gwasFineMappingLbfExample", + "fsusieFineMappingExample", + "mvsusieFineMappingExample" + ) +} + +.fmLoadExample <- function(name) { + env <- new.env() + data(list = name, package = "pecotmr", envir = env) + get(name, envir = env) +} + +# Row i of `x` as FineMappingRow() takes it: its element's columns as the +# topLoci table, plus its stored fit. +.fmExampleRowInputs <- function(x, i) { + el <- x[[i]] + md <- as.data.frame(S4Vectors::mcols(el), optional = TRUE) + ids <- sprintf( + "%s:%d:%s:%s", + as.character(GenomicRanges::seqnames(el)), + GenomicRanges::start(el), + md$A2, + md$A1 + ) + list( + variantIds = ids, + susieFit = S4Vectors::mcols(x)$susieFit[[i]], + topLoci = cbind(variant_id = ids, md), + cvResult = S4Vectors::mcols(x)$cvResult[[i]] + ) +} + +# Row i of `x` rebuilt through FineMappingRow(). +.fmExampleRow <- function(x, i) { + do.call(FineMappingRow, .fmExampleRowInputs(x, i)) +} + +# `x` rebuilt row by row, keeping its identity columns. +.fmRebuildExample <- function(x) { + md <- S4Vectors::mcols(x) + entry <- lapply(seq_len(nrow(x)), .fmExampleRow, x = x) + col <- function(nm) if (nm %in% colnames(md)) md[[nm]] else NULL + if (methods::is(x, "GwasFineMappingResult")) { + return(GwasFineMappingResult( + studyName = md$study, + method = md$method, + entry = entry, + blockId = col("blockId"), + traitPos = col("traitPos"), + ldReference = ldReference(x) + )) + } + QtlFineMappingResult( + studyName = md$study, + context = md$context, + trait = md$trait, + method = md$method, + entry = entry, + jointContexts = col("jointContexts"), + traitPos = col("traitPos"), + ldReference = ldReference(x) + ) +} + +# The per-variant columns collection `x` stores. +.fmStoredColumns <- function(x) { + colnames(S4Vectors::mcols(unlist(x, use.names = FALSE))) +} diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index 5150b6a9..470f5a6c 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -1,6 +1,6 @@ # Fixtures shared by the LD-statistic tests (LdEigen, LdScore, LdStatistic), -# the heritability tests (h2EstimationWrappers, H2Estimate) and -# test_genotypeHandle.R. +# the heritability tests (h2EstimationWrappers, H2Estimate, h2Annotations) +# and test_genotypeHandle.R. # ============================================================================= # Test data helpers @@ -150,3 +150,35 @@ makeTestH2Estimate <- function(with_enrichment = TRUE) { traitName = "test" ) } + +# ============================================================================= +# GWAS summary statistics over a reference's variants (shared by the +# heritability and fine-mapping annotation tests) +# ============================================================================= + +makeTestGwasGenotypeHandle <- function() { + new( + "GenotypeHandle", + path = "/tmp/test", + format = "plink2", + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ) +} + +.dfToGwasGr <- function(df) { + gr <- GenomicRanges::GRanges( + seqnames = df$CHR, + ranges = IRanges::IRanges(start = df$BP, width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = df$SNP, + A1 = df$A1, + A2 = df$A2, + Z = df$Z, + N = df$N + ) + gr +} diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index ae78338a..b4761604 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -705,12 +705,13 @@ test_that("variantIds on an empty collection defers too", { endoapply(x, utils::head, k) } -test_that("a fine-mapping row keeps its fit's variants when narrowed", { +test_that("a narrowed fine-mapping row keeps its fit whole", { x <- .rc_makeFmr(.rc_vids(1:10)) - expect_equal(as.character(x$fitVariants[[1L]]), .rc_vids(1:10)) + expect_false("fitVariants" %in% colnames(S4Vectors::mcols(x))) narrowed <- .alc_narrowed(x, 4L) expect_length(narrowed[[1L]], 4L) - expect_equal(as.character(narrowed$fitVariants[[1L]]), .rc_vids(1:10)) + expect_warning(fit <- susieFit(narrowed), "no longer holds") + expect_length(fit$pip, 10L) }) test_that("reading a narrowed row's fit warns and returns it unchanged", { @@ -762,76 +763,38 @@ test_that("intersectVariants restricts a narrowed row's fit by id", { expect_equal(colnames(fit$alpha), .rc_vids(11:30)) kept <- susieFit(x)$alpha[, .rc_vids(11:30)] expect_equal(unname(fit$alpha), unname(kept / rowSums(kept))) - expect_equal(as.character(out$fitVariants[[1L]]), .rc_vids(11:30)) + expect_length(out[[1L]], 20L) + expect_length(fit$pip, 20L) }) -test_that("updateObject() backfills the variants each fit was made with", { +test_that("updateObject() drops the fitVariants column older rows saved", { x <- .rc_makeFmr(.rc_vids(1:10)) saved <- x - saved$fitVariants <- NULL - expect_equal( - as.character(updateObject(saved)$fitVariants[[1L]]), - .rc_vids(1:10) - ) - # A row narrowed before it was saved: its fit still names all ten. - savedNarrowed <- .alc_narrowed(x, 4L) - savedNarrowed$fitVariants <- NULL - up <- updateObject(savedNarrowed) - expect_equal(as.character(up$fitVariants[[1L]]), .rc_vids(1:10)) - expect_warning(susieFit(up), "no longer holds") + saved$fitVariants <- IRanges::CharacterList(list(.rc_vids(1:10))) + up <- updateObject(saved) + expect_false("fitVariants" %in% colnames(S4Vectors::mcols(up))) + expect_identical(up, x) + # A row narrowed before it was saved still reads its whole fit. + savedNarrowed <- .alc_narrowed(saved, 4L) + expect_warning(fit <- susieFit(updateObject(savedNarrowed)), "no longer") + expect_length(fit$pip, 10L) # A current collection is left as it is. - expect_identical(updateObject(x)$fitVariants, x$fitVariants) + expect_identical(updateObject(x), x) expect_message(updateObject(x, verbose = TRUE), "updateObject") }) -test_that("updateObject() backfills fitVariants and keys LD rows in one call", { +test_that("updateObject() drops fitVariants and keys LD rows in one call", { x <- .rc_makeFmr(.rc_vids(1:10)) saved <- x - saved$fitVariants <- NULL + saved$fitVariants <- IRanges::CharacterList(list(.rc_vids(1:10))) up <- updateObject(.savedWithLdSketch(saved, NULL)) expect_true(validObject(up)) - expect_equal(as.character(up$fitVariants[[1L]]), .rc_vids(1:10)) + expect_false("fitVariants" %in% colnames(S4Vectors::mcols(up))) expect_identical(ldReference(up), list()) expect_true(is.na(up$ldReference)) expect_identical(updateObject(up), up) }) -test_that("updateObject(): an unnamed fit records its row, no fit none", { - vids <- .rc_vids(1:3) - tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) - saved <- QtlFineMappingResult( - studyName = c("s1", "s2"), - context = c("c1", "c1"), - trait = c("g1", "g1"), - method = c("susie", "susie"), - entry = list( - FineMappingRow(vids, list(pip = c(0.5, 0.3, 0.2)), tl), - FineMappingRow(vids, NULL, tl) - ) - ) - saved$fitVariants <- NULL - up <- updateObject(saved) - expect_equal(as.character(up$fitVariants[[1L]]), vids) - expect_equal(as.character(up$fitVariants[[2L]]), character(0)) -}) - -test_that(".fitNamedVariants reads a fit's names, never susieR's null column", { - f <- pecotmr:::.fitNamedVariants - expect_equal(f(NULL), character(0)) - expect_equal(f(list()), character(0)) - # A null_weight fit: one more effect-matrix column, named "null". - alpha <- matrix(0.5, 1L, 3L, dimnames = list(NULL, c("v1", "v2", "null"))) - expect_equal(f(list(alpha = alpha)), c("v1", "v2")) - expect_equal( - f(list(pip = c(v1 = 0.1, v2 = 0.2), alpha = alpha)), - c("v1", "v2") - ) - lbfMat <- matrix(0, 1L, 2L, dimnames = list(NULL, c("a", "b"))) - expect_equal(f(list(lbf_variable = lbfMat)), c("a", "b")) - # fSuSiE names its variables on csd_X. - expect_equal(f(list(csd_X = c(x1 = 1, x2 = 2))), c("x1", "x2")) -}) - # =========================================================================== # adjustPips: entries that share no variant with `keepVariants` # @@ -1075,12 +1038,25 @@ test_that("a flip complements AF but leaves MAF and N alone", { data(qtlSumStatsExample) x <- qtlSumStatsExample swapped <- .alc_replacementGr(x, swap = TRUE, payload = 0.3) + p <- parseVariantId(variantIds(x)) + ambiguous <- paste0(p$A2, p$A1) %in% c("AT", "TA", "CG", "GC") # An allele swap sends af -> 1 - af. maf is min(af, 1 - af) and the # sample size is a count, so both are swap-invariant -- complementing # them would corrupt them. - expect_equal(unique(af(fillFromReference(x, swapped, "AF"))), 0.7) - expect_equal(unique(maf(fillFromReference(x, swapped, "MAF"))), 0.3) - expect_equal(unique(sampleSize(fillFromReference(x, swapped, "N"))), 0.3) + filledAf <- af(fillFromReference(x, swapped, "AF")) + expect_equal(unique(filledAf[!ambiguous]), 0.7) + expect_equal( + unique(maf(fillFromReference(x, swapped, "MAF"))[!ambiguous]), + 0.3 + ) + expect_equal( + unique(sampleSize(fillFromReference(x, swapped, "N"))[!ambiguous]), + 0.3 + ) + # A swapped A/T or C/G variant is a swap or a strand flip and nothing says + # which, so it is not filled. + expect_true(any(ambiguous)) + expect_false(any(filledAf[ambiguous] %in% c(0.3, 0.7))) }) test_that("fillFromReference requires A1/A2 and says which column it read", { @@ -1483,3 +1459,188 @@ test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an emp ) expect_equal(length(fsusieAffectedRegions(res)), 0L) }) + +# =========================================================================== +# trimFineMappingResult: roles +# =========================================================================== + +test_that("trimFineMappingResult trims by role, picked by class", { + gwas <- trimFineMappingResult(.fmLoadExample("gwasFineMappingExample")) + expect_setequal(names(susieFit(gwas)), c("pip", "sets", "sets_secondary")) + qtl <- trimFineMappingResult(.fmLoadExample("qtlFineMappingExample")) + expect_setequal( + names(susieFit(qtl)), + c("alpha", "V", "pip", "sets", "sets_secondary") + ) + # Either class can play either role. + asAnnotation <- trimFineMappingResult( + .fmLoadExample("gwasFineMappingExample"), + role = "annotation" + ) + expect_true("alpha" %in% names(susieFit(asAnnotation))) + # The fit's class survives, so dispatch on it does too. + expect_identical( + class(susieFit(qtl)), + class(susieFit(.fmLoadExample("qtlFineMappingExample"))) + ) +}) + +test_that("trimming passes over what has nothing to trim", { + # A cross-validation-only row holds no variants and no fit. + cvOnly <- QtlFineMappingResult( + studyName = "s1", + context = "c1", + trait = "g1", + method = "susie", + entry = list(pecotmr:::.fmCvOnlyRow()) + ) + expect_identical(lengths(trimFineMappingResult(cvOnly)), lengths(cvOnly)) + expect_null(pecotmr:::.trimFit(NULL, "outcome")) + expect_identical(pecotmr:::.trimFit(list(), "annotation"), list()) + expect_null(pecotmr:::.trimNamed(NULL, "chr1:100:A:G")) +}) + +test_that("trimFineMappingResult refuses an unknown role or input", { + x <- .fmLoadExample("qtlFineMappingExample") + expect_error(trimFineMappingResult(x, role = "both"), "must be one of") + expect_error(trimFineMappingResult(list()), "GwasFineMappingResult") +}) + +test_that("an annotation trim keeps the effects of positive prior variance", { + x <- .fmLoadExample("gwasFineMappingExample") + inputs <- .fmExampleRowInputs(x, 1L) + inputs$susieFit$V[c(3L, 5L)] <- 0 + edited <- GwasFineMappingResult( + studyName = "s", + method = "susie", + entry = list(do.call(FineMappingRow, inputs)), + ldReference = ldReference(x) + ) + fit <- susieFit(trimFineMappingResult(edited, role = "annotation")) + kept <- setdiff(seq_along(inputs$susieFit$V), c(3L, 5L)) + expect_identical(rownames(fit$alpha), paste0("L", kept)) + expect_identical(names(fit$V), paste0("L", kept)) + expect_equal(unname(fit$alpha), unname(inputs$susieFit$alpha[kept, ])) + # The credible-set summary reads each effect's V by its id: positionally, + # L4 would get L5's. + full <- credibleSetSummary(edited) + trimmed <- credibleSetSummary(trimFineMappingResult(edited, "annotation")) + keptCs <- full$effect_id != "L3" + expect_equal(trimmed$V[keptCs], full$V[keptCs]) + expect_true(is.na(trimmed$V[!keptCs])) +}) + +test_that("a fit with no effect of positive prior variance keeps no rows", { + x <- .fmLoadExample("qtlFineMappingExample") + inputs <- .fmExampleRowInputs(x, 1L) + inputs$susieFit$V[] <- 0 + null <- QtlFineMappingResult( + "s", + "c", + "t", + "susie", + list(do.call(FineMappingRow, inputs)) + ) + fit <- susieFit(trimFineMappingResult(null)) + expect_identical(dim(fit$alpha), c(0L, ncol(inputs$susieFit$alpha))) + expect_length(fit$V, 0L) +}) + +# =========================================================================== +# trimFineMappingResult: what a trimmed collection keeps +# =========================================================================== + +test_that("trimming keeps names, the genome, LD references and metadata", { + x <- .fmLoadExample("qtlFineMappingExample") + S4Vectors::metadata(x) <- list(source = "test") + trimmed <- trimFineMappingResult(x) + expect_identical(names(trimmed), names(x)) + expect_identical(GenomeInfoDb::seqinfo(trimmed), GenomeInfoDb::seqinfo(x)) + expect_identical(ldReference(trimmed), ldReference(x)) + expect_identical(S4Vectors::metadata(trimmed), list(source = "test")) + expect_identical(studyName(trimmed), studyName(x)) +}) + +test_that("a trimmed collection stores only the variant identities", { + for (name in c("qtlFineMappingExample", "gwasFineMappingExample")) { + x <- .fmLoadExample(name) + trimmed <- trimFineMappingResult(x) + expect_setequal(.fmStoredColumns(trimmed), c("A1", "A2")) + expect_lt(utils::object.size(trimmed), utils::object.size(x) / 2) + expect_null(S4Vectors::mcols(trimmed)$cvResult[[1L]]) + } +}) + +test_that("a trimmed collection reports the same PIPs and credible sets", { + cols <- c("pip", "cs_95", "cs_70", "cs_50", "cs_95_purity") + for (name in c("qtlFineMappingExample", "gwasFineMappingExample")) { + x <- .fmLoadExample(name) + trimmed <- trimFineMappingResult(x) + expect_equal( + S4Vectors::mcols(topLoci(trimmed, signalCutoff = 0))[cols], + S4Vectors::mcols(topLoci(x, signalCutoff = 0))[cols], + info = name + ) + kept <- function(gr) { + S4Vectors::mcols(gr) <- S4Vectors::mcols(gr)[ + c("variant_id", "pip", "cs_70") + ] + gr + } + expect_equal( + kept(credibleSets(trimmed, coverage = 0.7)), + kept(credibleSets(x, coverage = 0.7)), + info = name + ) + } +}) + +test_that("trimming a trimmed collection changes nothing", { + trimmed <- trimFineMappingResult(.fmLoadExample("gwasFineMappingExample")) + expect_identical(trimFineMappingResult(trimmed), trimmed) + expect_identical( + trimFineMappingResult(trimmed, role = "outcome"), + trimmed + ) +}) + +test_that("a narrowed row trims to a fit that names its variables", { + # A row narrowed before trimming is found in its fit by name, so its + # trimmed fit keeps them; any other row's goes unnamed. + x <- .rc_makeFmr(.rc_vids(1:10)) + narrowed <- endoapply(x, utils::tail, 4L) + trimmed <- trimFineMappingResult(narrowed, role = "annotation") + expect_warning(fit <- susieFit(trimmed), "no longer holds") + expect_equal(names(fit$pip), .rc_vids(1:10)) + expect_null(names(susieFit(trimFineMappingResult(x))$pip)) + expect_equal( + suppressWarnings(topLoci(trimmed))$pip, + suppressWarnings(topLoci(narrowed))$pip + ) +}) + +test_that("a trimmed row narrowed afterwards cannot be read", { + # Its fit names no variables, so the PIPs it left to the fit have nowhere + # to come back from. + trimmed <- trimFineMappingResult(.rc_makeFmr(.rc_vids(1:10))) + narrowed <- endoapply(trimmed, utils::tail, 4L) + expect_error(topLoci(narrowed), "does not name its variables") +}) + +test_that("enrichment estimates are the same from trimmed collections", { + gwas <- .fmLoadExample("gwasFineMappingExample") + qtl <- .fmLoadExample("qtlFineMappingExample") + run <- function(g, q) { + suppressWarnings(qtlEnrichmentPipeline( + g, + q, + qtlEnrichmentParam = QtlEnrichmentParam(numGwas = 1e5, impN = 5), + seed = 1L, + verbose = FALSE + )) + } + expect_equal( + run(trimFineMappingResult(gwas), trimFineMappingResult(qtl)), + run(gwas, qtl) + ) +}) diff --git a/tests/testthat/test_GwasFineMappingResult.R b/tests/testthat/test_GwasFineMappingResult.R index cf2e1e50..6e881340 100644 --- a/tests/testthat/test_GwasFineMappingResult.R +++ b/tests/testthat/test_GwasFineMappingResult.R @@ -639,7 +639,7 @@ test_that("GwasFineMappingResult() keeps the caller's metadata", { expect_equal(S4Vectors::metadata(res), list(run = "r1")) }) -test_that("a fit-less entry split across chromosomes records no fit variants", { +test_that("a fit-less entry split across chromosomes reads without warning", { # Its rows hold one chromosome each; with no fit there is nothing for a # row to have narrowed, so none of them warns. ids <- c("chr1:100:A:G", "chr2:200:C:T") @@ -650,6 +650,6 @@ test_that("a fit-less entry split across chromosomes records no fit variants", { entry = list(FineMappingRow(ids, NULL, tl)) ) expect_equal(nrow(res), 2L) - expect_equal(unname(lengths(res$fitVariants)), c(0L, 0L)) + expect_false("fitVariants" %in% colnames(S4Vectors::mcols(res))) expect_no_warning(lbf(res)) }) diff --git a/tests/testthat/test_QtlFineMappingResult.R b/tests/testthat/test_QtlFineMappingResult.R index ab355d3e..b25c38c1 100644 --- a/tests/testthat/test_QtlFineMappingResult.R +++ b/tests/testthat/test_QtlFineMappingResult.R @@ -598,7 +598,7 @@ test_that("QtlFineMappingResult() keeps the caller's metadata", { ) }) -test_that("each row records the variants its fit was made with", { +test_that("rows record no fit variants: a row is its fit's variables", { row <- .sc_makeFineMappingRow(3) res <- QtlFineMappingResult( studyName = "s1", @@ -607,14 +607,13 @@ test_that("each row records the variants its fit was made with", { method = "susie", entry = list(row) ) - expect_s4_class(res$fitVariants, "CharacterList") - expect_equal( - as.character(res$fitVariants[[1L]]), - pecotmr:::.fmRowFitVariants(row) - ) + expect_false("fitVariants" %in% colnames(S4Vectors::mcols(res))) + expect_identical(susieFit(res), susieFit(row)) }) test_that("cvResult() of a narrowed row warns and returns it unchanged", { + # A row is narrowed when it holds fewer variants than its fit has, so + # it is the fit that tells. tl <- data.frame( variant_id = c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A"), pip = c(0.5, 0.3, 0.2) @@ -625,7 +624,12 @@ test_that("cvResult() of a narrowed row warns and returns it unchanged", { context = "c1", trait = "t1", method = "susie", - entry = list(FineMappingRow(tl$variant_id, NULL, tl, cvResult = cv)) + entry = list(FineMappingRow( + tl$variant_id, + list(pip = tl$pip), + tl, + cvResult = cv + )) ) narrowed <- endoapply(res, utils::head, 2L) expect_warning( diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index f8b2b360..4698b9bc 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -600,6 +600,31 @@ test_that("flattenTupleRanges drops non-broadcastable payload columns", { expect_true(is_in(".study", colnames(mcols(flat)))) }) +test_that("flattenTupleRanges restores a trimmed collection's PIPs and sets", { + # A trimmed row stores neither: every row's come back from its fit, and + # they are the values the untrimmed collection stores. + for (name in .fmExampleNames()) { + x <- .fmLoadExample(name) + trimmed <- S4Vectors::mcols(flattenTupleRanges(trimFineMappingResult( + x + ))) + full <- S4Vectors::mcols(flattenTupleRanges(x)) + shared <- intersect( + colnames(trimmed), + c( + "pip", + grep("^cs_[0-9]+(_purity)?$", colnames(full), value = TRUE) + ) + ) + expect_true("pip" %in% shared, info = name) + expect_equal( + as.data.frame(trimmed[shared]), + as.data.frame(full[shared]), + info = name + ) + } +}) + test_that("flattenTupleRanges rejects a non-collection", { expect_error( flattenTupleRanges(GenomicRanges::GRanges()), @@ -1248,3 +1273,28 @@ test_that("genomicRegion() is each row's span unless a region was stored", { expect_identical(genomicRegion(x), stored) expect_length(genomicRegion(x[0]), 0L) }) + +test_that("nesting a flattened trimmed collection leaves its fits' columns", { + # A trimmed collection leaves its pip and credible-set columns to its + # fits; flattening restores them, and re-nesting drops them again once + # the fits give them back exactly. + trimmed <- trimFineMappingResult(.fmLoadExample("qtlFineMappingExample")) + recorded <- S4Vectors::mcols(trimmed)$derivedColumns[[1L]] + expect_true(length(recorded) > 0L) + flat <- flattenTupleRanges(trimmed) + derived <- c("pip", "cs_95", "cs_95_purity") + expect_true(all(derived %in% colnames(S4Vectors::mcols(flat)))) + nested <- nestTupleRanges(flat, trimmed) + expect_false(any(derived %in% .fmStoredColumns(nested))) + expect_equal( + topLoci(nested, signalCutoff = 0), + topLoci(trimmed, signalCutoff = 0) + ) + # A credible-set column a verb changed no longer matches the fits, so it + # is stored as it was changed. + relabelled <- flat + S4Vectors::mcols(relabelled)$cs_95 <- "susie_0" + kept <- nestTupleRanges(relabelled, trimmed) + expect_true("cs_95" %in% .fmStoredColumns(kept)) + expect_true(all(S4Vectors::mcols(unlist(kept))$cs_95 == "susie_0")) +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index 948c878f..3941fcfa 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -2130,9 +2130,14 @@ test_that("an unnamed LBF matrix is named by the variants of its fit", { context = "c1", trait = "g1", method = "susie", - entry = list(FineMappingRow(vids, list(pip = tl$pip), tl)) + entry = list(FineMappingRow( + vids, + list(pip = set_names(tl$pip, vids)), + tl + )) ) - # The row holds two of the three variants the fit's columns are. + # The row holds two of the three variants the fit's columns are, found + # by the names the fit gives them. parts <- pecotmr:::.fmrRowParts(endoapply(res, utils::head, 2L), 1L) named <- pecotmr:::.colocLbfNamesFrom(matrix(c(1, 2, 3), 1L), parts) expect_equal(colnames(named), vids) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 0afcabd8..7b71c5b9 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -514,21 +514,21 @@ test_that("adjustPips errors when alpha's width matches neither variant count", test_that("adjustPips restricts a narrowed row's fit by the fit's own ids", { # The row holds variants 3:6 of the six its fit was made with. The kept - # ones are found among the fit's columns by id, not by their position in - # the row, which would pick the fit's columns 1:2. + # ones are found among the fit's columns by the names the fit gives them, + # not by their position in the row, which would pick the fit's columns + # 1:2. vids <- paste0("chr1:", 1:6, ":A:G") entry <- .makeAdjustEntry(vids) narrowed <- methods::new( "FineMappingRow", variants = variants(entry)[3:6], - susieFit = susieFit(entry), - fitVariants = vids + susieFit = susieFit(entry) ) adj <- adjustPips(narrowed, vids[3:4]) alpha <- susieFit(entry)$alpha[, 3:4] expect_equal(variantIds(adj), vids[3:4]) expect_equal(unname(susieFit(adj)$alpha), unname(alpha / rowSums(alpha))) - expect_equal(pecotmr:::.fmRowFitVariants(adj), vids[3:4]) + expect_length(susieFit(adj)$pip, 2L) }) test_that("adjustPips refuses a row holding a variant its fit never had", { @@ -543,19 +543,6 @@ test_that("adjustPips refuses a row holding a variant its fit never had", { ) }) -test_that("a row records its fit's variants only when it carries a fit", { - vids <- paste0("chr1:", 1:3, ":A:G") - tl <- data.frame(variant_id = vids, pip = c(0.5, 0.3, 0.2)) - fitted <- FineMappingRow(vids, list(pip = tl$pip), tl) - expect_equal(pecotmr:::.fmRowFitVariants(fitted), vids) - cvOnly <- FineMappingRow(vids, NULL, tl, cvResult = list(r2 = 0.1)) - expect_equal(pecotmr:::.fmRowFitVariants(cvOnly), vids) - expect_equal( - pecotmr:::.fmRowFitVariants(FineMappingRow(vids, list(), tl)), - character(0) - ) -}) - test_that("adjustPips recomputes credible sets instead of remapping indices", { vids <- paste0("chr1:", 1:6, ":A:G") p <- length(vids) @@ -1735,3 +1722,259 @@ test_that("a fit whose prior variances all vanished labels nothing", { adj <- adjustPips(entry, vids[1:3]) expect_equal(.fmrRowTopLoci(adj, raw = TRUE)$cs_95, rep("susie_0", 3L)) }) + +# =========================================================================== +# A row stores no per-variant pip column when its fit reproduces it: every +# view restores it from the fit. These tests rebuild each bundled example -- +# saved with the column -- through FineMappingRow() and check that nothing a +# caller can see changes. +# =========================================================================== + +.fpd_hasStoredPip <- function(x) { + "pip" %in% .fmStoredColumns(x) +} + +.fpd_csColumns <- c( + "cs_95", + "cs_70", + "cs_50", + "cs_95_purity", + "cs_70_purity", + "cs_50_purity" +) + +test_that("a rebuilt row stores no pip its fit reproduces", { + x <- .fmLoadExample("qtlFineMappingExample") + expect_true(.fpd_hasStoredPip(x)) + expect_false(.fpd_hasStoredPip(.fmRebuildExample(x))) +}) + +test_that("a rebuilt row stores no credible-set column its fit reproduces", { + x <- .fmLoadExample("qtlFineMappingExample") + expect_true(all(.fpd_csColumns %in% .fmStoredColumns(x))) + new <- .fmRebuildExample(x) + expect_false(any(.fpd_csColumns %in% .fmStoredColumns(new))) + # The row as GRanges derives them back, in buildTopLoci()'s order. + restored <- as(.fmExampleRow(x, 1L), "GRanges") + expect_identical( + colnames(S4Vectors::mcols(restored)), + colnames(S4Vectors::mcols(x[[1L]])) + ) +}) + +test_that("credible-set columns the fit cannot give back are stored", { + inputs <- .fmExampleRowInputs(.fmLoadExample("qtlFineMappingExample"), 1L) + stored <- function(inputs) { + row <- do.call(FineMappingRow, inputs) + q <- QtlFineMappingResult("s", "c", "t", "susie", list(row)) + intersect(.fpd_csColumns, .fmStoredColumns(q)) + } + # Without the secondary credible sets the 0.7 and 0.5 columns have no + # source, and the block is kept whole. + noSecondary <- inputs + noSecondary$susieFit$sets_secondary <- NULL + expect_identical(stored(noSecondary), .fpd_csColumns) + # Nor is a relabelled column re-derived over. + relabelled <- inputs + relabelled$topLoci$cs_70 <- sub("_[0-9]+$", "_9", relabelled$topLoci$cs_70) + expect_identical(stored(relabelled), .fpd_csColumns) + row <- do.call(FineMappingRow, relabelled) + expect_identical( + S4Vectors::mcols(as(row, "GRanges"))$cs_70, + relabelled$topLoci$cs_70 + ) + # A table with only some of the block is not laid out as the fit writes + # it. + partial <- inputs + partial$topLoci$cs_50_purity <- NULL + expect_identical(stored(partial), setdiff(.fpd_csColumns, "cs_50_purity")) +}) + +test_that("every view of a rebuilt example is unchanged", { + for (name in .fmExampleNames()) { + old <- .fmLoadExample(name) + new <- .fmRebuildExample(old) + same <- function(f) { + expect_equal(f(new), f(old), info = name) + } + same(function(x) topLoci(x)) + same(function(x) topLoci(x, signalCutoff = 0)) + same(function(x) topLoci(x, signalCutoff = 0.1, minPurity = 0.5)) + for (coverage in c(0.95, 0.7, 0.5)) { + same(function(x) credibleSets(x, coverage = coverage)) + } + same(function(x) credibleSetSummary(x)) + same(function(x) marginalEffects(x)) + same(flattenTupleRanges) + same(function(x) as(x, "GRanges")) + } +}) + +test_that("pip() of a rebuilt row comes from its fit", { + old <- .fmLoadExample("gwasFineMappingExample") + new <- .fmRebuildExample(old) + expect_equal(pip(new), pip(old)) + expect_false(anyNA(pip(new))) +}) + +test_that("the BED writer writes the same table for a rebuilt example", { + for (name in c("qtlFineMappingExample", "gwasFineMappingExample")) { + old <- .fmLoadExample(name) + paths <- c(withr::local_tempfile(), withr::local_tempfile()) + writeBed(old, paths[[1L]], signalCutoff = 0) + writeBed(.fmRebuildExample(old), paths[[2L]], signalCutoff = 0) + expect_identical( + readLines(paths[[2L]]), + readLines(paths[[1L]]), + info = name + ) + } +}) + +test_that("a flatten / nest round trip keeps the pip column dropped", { + new <- .fmRebuildExample(.fmLoadExample("qtlFineMappingExample")) + flat <- flattenTupleRanges(new) + expect_true("pip" %in% colnames(S4Vectors::mcols(flat))) + expect_true(all(.fpd_csColumns %in% colnames(S4Vectors::mcols(flat)))) + back <- nestTupleRanges(flat, new) + expect_false(.fpd_hasStoredPip(back)) + expect_false(any(.fpd_csColumns %in% .fmStoredColumns(back))) + expect_equal( + topLoci(back, signalCutoff = 0), + topLoci(new, signalCutoff = 0) + ) + # A verb that changes the PIPs keeps its own values. + halved <- flat + S4Vectors::mcols(halved)$pip <- S4Vectors::mcols(halved)$pip / 2 + edited <- nestTupleRanges(halved, new) + expect_true(.fpd_hasStoredPip(edited)) + expect_equal( + S4Vectors::mcols(topLoci(edited, signalCutoff = 0))$pip, + S4Vectors::mcols(topLoci(new, signalCutoff = 0))$pip / 2 + ) +}) + +test_that("a pip its fit does not give is stored", { + inputs <- .fmExampleRowInputs(.fmLoadExample("qtlFineMappingExample"), 1L) + inputs$topLoci$pip <- inputs$topLoci$pip / 2 + edited <- do.call(FineMappingRow, inputs) + expect_equal( + S4Vectors::mcols(as(edited, "GRanges"))$pip, + inputs$topLoci$pip + ) + # No fit at all: the table's pip is the only one there is. + bare <- FineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + susieFit = list(), + topLoci = data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0.9, 0.1) + ) + ) + expect_equal(S4Vectors::mcols(as(bare, "GRanges"))$pip, c(0.9, 0.1)) +}) + +test_that("a collection joining saved and rebuilt rows reads every pip", { + old <- .fmLoadExample("qtlFineMappingLbfExample") + new <- .fmRebuildExample(old) + mixed <- c(old[1L], new[2L]) + expect_equal( + topLoci(mixed, signalCutoff = 0), + topLoci(old, signalCutoff = 0) + ) +}) + +# =========================================================================== +# Restoring the columns a row leaves to its fit: where nothing is restored +# =========================================================================== + +.fmr_ids <- c("chr1:100:A:G", "chr1:200:C:T") + +# A row's variants as stored, from a fit that gives none of its columns +# back, so the table's pip and credible-set columns all stay. +.fmr_storedVariants <- function() { + variants(FineMappingRow( + .fmr_ids, + list(), + data.frame( + variant_id = .fmr_ids, + pip = c(0.4, 0.6), + cs_95 = c("susie_1", "susie_0"), + cs_95_purity = c(0.9, 0) + ) + )) +} + +test_that("the pip and credible-set slots follow their anchor columns", { + expect_identical(pecotmr:::.fmRowPipSlot(c("variant_id", "beta")), 0L) + expect_identical(pecotmr:::.fmRowPipSlot(c("A2", "marginal_p", "x")), 2L) + expect_identical(pecotmr:::.fmRowCsSlot(c("A2", "logBF", "x")), 2L) + expect_identical(pecotmr:::.fmRowCsSlot(c("A2", "pip", "x")), 2L) + expect_identical(pecotmr:::.fmRowCsSlot(c("A2", "x")), 1L) +}) + +test_that("credible-set labels give a method tag only when they share one", { + tag <- pecotmr:::.fmRowCsLabelTag + expect_identical( + tag(S4Vectors::DataFrame(cs_95 = c("susie_1", "susie_0"))), + "susie" + ) + expect_null(tag(S4Vectors::DataFrame(cs_95 = c("susie_1", "fsusie_1")))) + expect_null(tag(S4Vectors::DataFrame(cs_95 = c("_1", "_2")))) +}) + +test_that("a fit gives no credible-set columns it cannot place or label", { + fit <- list(pip = c(0.5, 0.5)) + cols <- pecotmr:::.fitCsColumns + expect_null(cols(fit, "cs_95", NULL, 1:2, 2L)) + expect_null(cols(fit, "cs_95", "susie", NULL, 2L)) + expect_null(cols(fit, "cs_95", "susie", c(1L, NA), 2L)) + # Nor without the credible sets of the coverage asked for. + expect_null(cols(fit, "cs_95", "susie", 1:2, 2L)) +}) + +test_that("restoring leaves what a row stores, or its fit cannot give", { + gr <- .fmr_storedVariants() + row <- methods::new( + "FineMappingRow", + variants = gr, + susieFit = list(pip = c(0.4, 0.6)), + derivedColumns = c("cs_95", "method=susie") + ) + # Every credible-set column it records is stored. + expect_identical(pecotmr:::.fmRowRestoreFitCs(gr, row), gr) + # Without them, a fit with no credible sets gives nothing back. + bare <- gr + S4Vectors::mcols(bare) <- S4Vectors::mcols(gr)[, c("A1", "A2", "pip")] + expect_identical(pecotmr:::.fmRowRestoreFitCs(bare, row), bare) + # A fit with no PIPs gives no pip back. + noPip <- bare + S4Vectors::mcols(noPip) <- S4Vectors::mcols(gr)[, c("A1", "A2")] + fitless <- methods::new( + "FineMappingRow", + variants = noPip, + susieFit = list(alpha = matrix(0.5, 1L, 2L)) + ) + expect_identical(pecotmr:::.fmRowRestoreFitPip(noPip, fitless), noPip) +}) + +test_that(".fmRowFillColumn fills only a column left all NA", { + md <- S4Vectors::DataFrame(a = c(1, 2), b = c(NA_real_, NA_real_)) + derived <- list(a = c(9, 9), b = c(3, 4)) + expect_identical(pecotmr:::.fmRowFillColumn(md, "a", derived), md) + filled <- pecotmr:::.fmRowFillColumn(md, "b", derived) + expect_identical(filled$b, c(3, 4)) + expect_identical(filled$a, md$a) +}) + +test_that("a row saved before rows recorded derived columns derives none", { + row <- FineMappingRow( + .fmr_ids, + list(pip = c(0.4, 0.6)), + data.frame(variant_id = .fmr_ids, pip = c(0.4, 0.6)) + ) + old <- row + attr(old, "derivedColumns") <- NULL + expect_false(methods::.hasSlot(old, "derivedColumns")) + expect_identical(pecotmr:::.fmRowDerivedColumns(old), character(0)) +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 8c3c4312..e04e097a 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -3487,7 +3487,10 @@ test_that("extractCsInfo names a narrowed row's sets by the fit's variants", { tl <- data.frame(variant_id = vids, pip = pip, z = c(1, 4, 2, 0.5)) fe <- .testFineMappingRow( variantIds = vids, - susieFit = list(pip = pip, sets = list(cs = list(L_1 = c(2L, 3L)))), + susieFit = list( + pip = set_names(pip, vids), + sets = list(cs = list(L_1 = c(2L, 3L))) + ), topLoci = tl ) narrowed <- endoapply(fe, utils::tail, 3L) @@ -3519,7 +3522,7 @@ test_that("computeCsCorrelation of a narrowed row warns, on the fit's sets", { variantIds = vids, susieFit = list( sets = list(cs = list(L_1 = 1:3, L_2 = 90:91)), - pip = rep(0.01, length(vids)) + pip = set_names(rep(0.01, length(vids)), vids) ) ) full <- computeCsCorrelation(fe, ss) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index af15fef1..30ceb984 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -2558,3 +2558,35 @@ test_that(".updatePanel refuses a saved panel it cannot read again", { expect_s3_class(cnd, "pecotmrUnreadablePanel") expect_match(conditionMessage(cnd), "no longer hold every variant") }) + +# --- .pvarHeader / .readPvarTable: where the variants start ----------------- + +.gio_pvar <- function(lines) { + path <- tempfile(fileext = ".pvar") + writeLines(lines, path) + path +} + +test_that(".pvarHeader finds the #CHROM line after the meta lines", { + meta <- sprintf("##contig=", 1:5) + path <- .gio_pvar(c(meta, "#CHROM\tPOS\tID\tREF\tALT", "1\t10\tv1\tA\tG")) + header <- pecotmr:::.pvarHeader(path) + expect_identical(header$columns, c("CHROM", "POS", "ID", "REF", "ALT")) + expect_identical(header$lines, 6L) + # Past the first window it reads a wider one. + expect_identical(pecotmr:::.pvarHeader(path, window = 2L), header) +}) + +test_that(".pvarHeader is NULL without a header before the variants", { + noHeader <- .gio_pvar(c("##fileformat=PVARv1.0", "1\t10\tv1\tA\tG")) + expect_null(pecotmr:::.pvarHeader(noHeader)) + metaOnly <- .gio_pvar(c("##fileformat=PVARv1.0", "##source=test")) + expect_null(pecotmr:::.pvarHeader(metaOnly)) + expect_null(pecotmr:::.pvarHeader(metaOnly, window = 1L)) +}) + +test_that(".readPvarTable declines what it cannot read as a table", { + expect_null(pecotmr:::.readPvarTable("panel.pvar.zst")) + path <- .gio_pvar(c("#CHROM\tPOS\tID", "1\t10\tv1")) + expect_null(pecotmr:::.readPvarTable(path)) +}) diff --git a/tests/testthat/test_h2Annotations.R b/tests/testthat/test_h2Annotations.R index 53d0606f..f6a87644 100644 --- a/tests/testthat/test_h2Annotations.R +++ b/tests/testthat/test_h2Annotations.R @@ -425,3 +425,242 @@ test_that(".readLdscAnnot errors when CHR/BP columns are absent", { "must contain CHR and BP columns" ) }) + +# ============================================================================= +# fineMappingAnnotations (h2Annotations.R) +# ============================================================================= + +# An LD-score reference over `n` variants at chr1:100, 200, ..., named by +# rsID, in `nBlocks` blocks with identity LD. `flip` lists variants it +# stores with the alleles the other way round. +.fma_ref <- function(n = 6L, nBlocks = 2L, flip = integer(0)) { + a1 <- rep("G", n) + a2 <- rep("A", n) + a1[flip] <- "A" + a2[flip] <- "G" + per <- n / nBlocks + LdScore( + ldBlocks = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = (seq_len(nBlocks) - 1L) * per * 100L + 1L, + end = seq_len(nBlocks) * per * 100L + ) + ), + snpInfo = data.frame( + SNP = paste0("rs", seq_len(n)), + CHR = "chr1", + BP = seq_len(n) * 100L, + A1 = a1, + A2 = a2 + ), + nSamples = 1000L, + inSample = FALSE, + genome = "hg19", + ldScores = matrix(1, n, 1, dimnames = list(NULL, "base_l2")), + ldScoreWeights = rep(1, n), + ldMatrixList = lapply(seq_len(nBlocks), function(b) { + list( + R = diag(per), + snpIdx = as.integer((b - 1L) * per + seq_len(per)) + ) + }) + ) +} + +# One gene's row over variants `idx` (ids chr1::A:G) with PIPs `pip`, +# 95% credible-set members `cs` and their purity. +.fma_row <- function(idx, pip, cs, purity) { + ids <- sprintf("chr1:%d:A:G", idx * 100L) + FineMappingRow( + variantIds = ids, + susieFit = list(pip = stats::setNames(pip, ids)), + topLoci = data.frame( + variant_id = ids, + pip = pip, + cs_95 = ifelse(seq_along(idx) %in% cs, "susie_1", "susie_0"), + cs_95_purity = ifelse(seq_along(idx) %in% cs, purity, 0) + ) + ) +} + +# Two genes of one context sharing variants 3 and 4. +.fma_qtl <- function() { + QtlFineMappingResult( + studyName = c("Q", "Q"), + context = c("ctx", "ctx"), + trait = c("g1", "g2"), + method = c("susie", "susie"), + entry = list( + .fma_row(1:4, c(0.7, 0.2, 0.05, 0.05), cs = 1:2, purity = 0.9), + .fma_row(3:6, c(0.6, 0.1, 0.2, 0.1), cs = c(1L, 3L), purity = 0.3) + ) + ) +} + +.fma_col <- function(annot, type) { + unname(SummarizedExperiment::assay(annot, "annotations")[, + paste0("Q|ctx|susie|", type) + ]) +} + +test_that("fineMappingAnnotations builds max and summed PIP over the traits", { + annot <- fineMappingAnnotations(.fma_qtl(), .fma_ref()) + # Variant 3 carries both genes: 0.05 and 0.6. + expect_equal(.fma_col(annot, "maxCpp"), c(0.7, 0.2, 0.6, 0.1, 0.2, 0.1)) + expect_equal(.fma_col(annot, "sumPip"), c(0.7, 0.2, 0.65, 0.15, 0.2, 0.1)) + expect_equal(.fma_col(annot, "highPip"), c(1, 0, 1, 0, 0, 0)) + expect_equal(.fma_col(annot, "credibleSet"), c(1, 1, 1, 0, 1, 0)) +}) + +test_that("fineMappingAnnotations rows follow the reference", { + ref <- .fma_ref() + annot <- fineMappingAnnotations(.fma_qtl(), ref) + expect_identical(nrow(annot), length(ref)) + expect_identical( + GenomicRanges::start(SummarizedExperiment::rowRanges(annot)), + GenomicRanges::start(ref) + ) + meta <- as.data.frame(SummarizedExperiment::colData(annot)) + expect_identical( + meta$name, + paste0("Q|ctx|susie|", c("maxCpp", "sumPip", "credibleSet", "highPip")) + ) + expect_identical(unique(meta$tier), "candidate") + expect_identical( + meta$type, + c("continuous", "continuous", "binary", "binary") + ) + baseline <- fineMappingAnnotations(.fma_qtl(), ref, tier = "baseline") + expect_identical( + unique(SummarizedExperiment::colData(baseline)$tier), + "baseline" + ) +}) + +test_that("fineMappingAnnotations matches a reference variant stored flipped", { + annot <- fineMappingAnnotations(.fma_qtl(), .fma_ref(flip = 1L)) + expect_equal(.fma_col(annot, "maxCpp")[[1L]], 0.7) +}) + +test_that("fineMappingAnnotations takes the coverage, purity and threshold", { + qtl <- .fma_qtl() + ref <- .fma_ref() + pure <- fineMappingAnnotations( + qtl, + ref, + types = "credibleSet", + minPurity = 0.5 + ) + expect_equal(.fma_col(pure, "credibleSet"), c(1, 1, 0, 0, 0, 0)) + low <- fineMappingAnnotations( + qtl, + ref, + types = "highPip", + pipThreshold = 0.2 + ) + expect_equal(.fma_col(low, "highPip"), c(1, 1, 1, 0, 1, 0)) + # No credible sets were stored at 70% coverage. + expect_warning( + none <- fineMappingAnnotations( + qtl, + ref, + types = c("maxCpp", "credibleSet"), + coverage = 0.7 + ), + "dropping 1 column" + ) + expect_identical(colnames(none), "Q|ctx|susie|maxCpp") +}) + +test_that("fineMappingAnnotations refuses bad arguments", { + expect_error( + fineMappingAnnotations(.fma_qtl(), .fma_ref(), types = "meanPip"), + "must be one of" + ) + expect_error( + fineMappingAnnotations(.fma_qtl(), .fma_ref(), tier = "tested"), + "must be one of" + ) + expect_error(fineMappingAnnotations(.fma_qtl(), list()), "LdStatistic") +}) + +test_that("fineMappingAnnotations skips a purity filter it has no purity for", { + ids <- sprintf("chr1:%d:A:G", 1:4 * 100L) + pip <- c(0.7, 0.2, 0.05, 0.05) + # Labels without purities: the row stores them as given. + row <- FineMappingRow( + variantIds = ids, + susieFit = list(pip = stats::setNames(pip, ids)), + topLoci = data.frame( + variant_id = ids, + pip = pip, + cs_95 = c("susie_1", "susie_1", "susie_0", "susie_0") + ) + ) + qtl <- QtlFineMappingResult( + studyName = "Q", + context = "ctx", + trait = "g1", + method = "susie", + entry = list(row) + ) + expect_warning( + annot <- fineMappingAnnotations( + qtl, + .fma_ref(), + types = "credibleSet", + minPurity = 0.5 + ), + "no purity column 'cs_95_purity'" + ) + expect_equal(.fma_col(annot, "credibleSet"), c(1, 1, 0, 0, 0, 0)) +}) + +test_that("estimateH2 takes fineMappingAnnotations as candidates", { + n <- 40L + ref <- .fma_ref(n = n, nBlocks = 4L) + set.seed(5) + df <- data.frame( + SNP = paste0("rs", seq_len(n)), + CHR = "chr1", + BP = seq_len(n) * 100L, + A1 = "G", + A2 = "A", + Z = stats::rnorm(n, sd = 1.5), + N = 50000 + ) + ss <- GwasSumStats( + studyName = "t", + entry = list(.dfToGwasGr(df)), + genome = "hg19", + ldReference = makeTestGwasGenotypeHandle() + ) + qtl <- QtlFineMappingResult( + "Q", + "ctx", + "g1", + "susie", + list(.fma_row( + seq(2L, n, by = 3L), + rep(0.3, length(seq(2L, n, by = 3L))), + cs = 1:3, + purity = 0.9 + )) + ) + annot <- fineMappingAnnotations( + qtl, + ref, + types = c("maxCpp", "credibleSet") + ) + for (method in c("sldsc", "gldsc")) { + z <- scoreStats(estimateH2( + ss, + ref, + method = method, + annotations = annot + ))$z + expect_length(z, 2L) + expect_true(all(is.finite(z)), info = method) + } +}) diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index a0f481d3..7f581076 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -352,13 +352,23 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { ) } hdl <- pecotmr:::hdlUnivariate - for (an in list(NULL, annot)) { - expect_equal( - suppressWarnings(hdl(z, n, lazyEigen, an, TRUE)), - suppressWarnings(hdl(z, n, storedEigen, an, TRUE)), - tolerance = 1e-6 - ) + expect_equal( + suppressWarnings(hdl(z, n, lazyEigen, NULL, TRUE)), + suppressWarnings(hdl(z, n, storedEigen, NULL, TRUE)), + tolerance = 1e-6 + ) + # Stratified, this fixture (a 100-sample panel, so the intercept sits at + # its bound) leaves the likelihood flat along the base / annotation + # ridge: the two optima have the same likelihood to 1e-7 but sit apart + # along it, so only the total heritability is pinned down. + stratifiedH2 <- function(ref) { + suppressWarnings(hdl(z, n, ref, annot, TRUE))$h2 } + expect_equal( + stratifiedH2(lazyEigen), + stratifiedH2(storedEigen), + tolerance = 1e-3 + ) # The truncated decompositions HDL conventionally uses agree too. lazy9 <- buildLdEigen( fx$panel, @@ -367,11 +377,7 @@ test_that("estimators read a panel's LD on demand as they read stored LD", { eigenvalueTruncation = 0.9 ) stored9 <- buildLdEigen(fx$ld, genome = "hg19", eigenvalueTruncation = 0.9) - expect_equal( - suppressWarnings(hdl(z, n, lazy9, annot, TRUE)), - suppressWarnings(hdl(z, n, stored9, annot, TRUE)), - tolerance = 1e-6 - ) + expect_equal(stratifiedH2(lazy9), stratifiedH2(stored9), tolerance = 1e-3) }) # =========================================================================== @@ -456,33 +462,6 @@ test_that("h2EstimateToSldscTrait creates 1-row dummy when annotationJackknifeCo # Helper: GwasSumStats matched to a reference panel # =========================================================================== -makeTestGwasGenotypeHandle <- function() { - new( - "GenotypeHandle", - path = "/tmp/test", - format = "plink2", - snpInfo = data.frame(), - nSamples = 0L, - sampleIds = character(), - pgenPtr = NULL - ) -} - -.dfToGwasGr <- function(df) { - gr <- GenomicRanges::GRanges( - seqnames = df$CHR, - ranges = IRanges::IRanges(start = df$BP, width = 1L) - ) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = df$SNP, - A1 = df$A1, - A2 = df$A2, - Z = df$Z, - N = df$N - ) - gr -} - makeTestSumstatsForRef <- function( ref, traitName = "test", @@ -615,6 +594,43 @@ test_that("estimateH2 rejects annotations that do not cover the reference", { ) }) +test_that("estimateH2 rejects annotations at other coordinates or in another order", { + ref <- makeTestEigenRef() + ss <- makeTestSumstatsForRef(ref) + annot <- makeTestAnnotations() + # The right count of rows is not enough: the estimators read annotation + # rows by the reference's variant order. + relocate <- function(starts) { + AnnotationMatrix( + SummarizedExperiment::assay(annot, "annotations"), + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(starts, width = 1L) + ), + as.data.frame(SummarizedExperiment::colData(annot)), + genome = "hg19" + ) + } + expect_error( + estimateH2( + ss, + ref, + method = "lder", + annotations = relocate(GenomicRanges::start(ref) + 1L) + ), + "`annotations` and the LD reference disagree at 20 of 20 position" + ) + expect_error( + estimateH2( + ss, + ref, + method = "lder", + annotations = relocate(rev(GenomicRanges::start(ref))) + ), + "`annotations` and the LD reference disagree" + ) +}) + test_that("estimateH2 rejects a genome build mismatch", { ref <- makeTestEigenRef() ss <- makeTestSumstatsForRef(ref) @@ -929,71 +945,6 @@ test_that(".jackknifeSeFromLoo equals the pseudo-value jackknife", { ) }) -# ============================================================================= -# computeBaselineEnrichment -# ============================================================================= - -test_that("computeBaselineEnrichment computes enrichment and propSnps", { - M <- 100 - baseline_mat <- matrix(0, nrow = M, ncol = 2) - baseline_mat[1:50, 1] <- 1 - baseline_mat[, 2] <- 1 - tau <- c(0.01, 0.005) - tauSe <- c(0.002, 0.001) - h2 <- 0.5 - annot_names <- c("annot1", "base") - res <- pecotmr:::computeBaselineEnrichment( - tau, - tauSe, - NULL, - baseline_mat, - annot_names, - h2 - ) - expect_s3_class(res, "data.frame") - expected_cols <- c( - "annotation", - "tau", - "tauSe", - "enrichment", - "enrichmentSe", - "enrichmentP", - "propH2", - "propSnps" - ) - expect_named(res, expected_cols) - expect_equal(nrow(res), 2) - expect_equal(res$enrichment, tau * M / h2) - expect_equal(res$propSnps, c(0.5, 1.0)) -}) - -test_that("computeBaselineEnrichment uses jackknife blocks when provided", { - M <- 100 - nBlocks <- 5 - baseline_mat <- matrix(0, nrow = M, ncol = 2) - baseline_mat[1:50, 1] <- 1 - baseline_mat[, 2] <- 1 - tau <- c(0.01, 0.005) - tauSe <- c(0.002, 0.001) - h2 <- 0.5 - annot_names <- c("annot1", "base") - annotationJackknifeCoefs <- matrix( - rep(tau, each = nBlocks), - nrow = nBlocks, - ncol = 2 - ) - res <- pecotmr:::computeBaselineEnrichment( - tau, - tauSe, - annotationJackknifeCoefs, - baseline_mat, - annot_names, - h2 - ) - # With constant annotationJackknifeCoefs, enrichmentSe should be 0 - expect_equal(res$enrichmentSe, c(0, 0)) -}) - # ============================================================================= # standardizeTauStar # ============================================================================= @@ -1404,11 +1355,12 @@ makeCoverageAnnot <- function( AnnotationMatrix(mat, snp_gr, meta, genome = "hg19") } -# The three estimators, each with the reference it reads and the baseline +# The four estimators, each with the reference it reads and the baseline # its annotations take. An all-ones baseline makes the LDER and HDL -# eigenvalue-score column the eigenvalue itself; for g-LDSC it would repeat -# the base LD score column and leave the design singular, so g-LDSC takes a -# half-on/half-off baseline instead. +# eigenvalue-score column the eigenvalue itself; for g-LDSC and S-LDSC it +# would repeat the base LD score column and leave the design singular, so +# they take a half-on/half-off baseline instead. S-LDSC reports its local +# heritability per variant rather than per block (`perBlockLocal`). .h2Runs <- list( lder = list( fn = pecotmr:::lderUnivariate, @@ -1424,6 +1376,12 @@ makeCoverageAnnot <- function( fn = pecotmr:::hdlUnivariate, ref = "eigen_ref", baseline = "ones" + ), + sldsc = list( + fn = pecotmr:::sldscUnivariate, + ref = "ld_score_ref", + baseline = "spatial", + perBlockLocal = FALSE ) ) @@ -1487,6 +1445,9 @@ test_that("lderUnivariate intercept is near zero for well-calibrated data", { test_that("each univariate estimator with local = TRUE returns per-block h2", { for (method in names(.h2Runs)) { + if (isFALSE(.h2Runs[[method]]$perBlockLocal)) { + next + } res <- .h2Run(method, dat, local = TRUE) expect_true(is.data.frame(res$local), info = method) expect_true( @@ -1543,6 +1504,9 @@ test_that("each univariate estimator reports enrichment and score statistics", { test_that("each estimator with annotations and local = TRUE gives local h2", { for (method in names(.h2Runs)) { + if (isFALSE(.h2Runs[[method]]$perBlockLocal)) { + next + } annot <- .h2RunAnnot(method, dat_annot, 1L) res <- .h2Run(method, dat_annot, annotations = annot, local = TRUE) expect_true(is.data.frame(res$local), info = method) @@ -1744,6 +1708,261 @@ test_that("lderUnivariate recovers a known h2 (deterministic, seed = 1)", { expect_equal(mean(ests), 0.389, tolerance = 0.04) }) +# =========================================================================== +# Candidate-annotation score tests: calibration and power +# +# A candidate's score is calibrated by the spread of its LD blocks' scores, so +# under the null its z is close to N(0, 1) whatever the regression weights +# get wrong. Both LD-score estimators are checked through estimateH2(). +# =========================================================================== + +# A half-on/half-off baseline annotation plus the candidate `cand`. +.h2ScoreAnnot <- function(M, cand) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = as.integer(seq_len(M) * 100L), width = 1L) + ) + mat <- cbind(half = as.integer(seq_len(M) <= M / 2), cand = cand) + meta <- data.frame( + name = c("half", "cand"), + tier = c("baseline", "candidate"), + type = "binary" + ) + AnnotationMatrix(mat, gr, meta, genome = "hg19") +} + +# Simulated z-scores over the recovery reference as a GwasSumStats. +.h2ScoreSumstats <- function(d, z) { + df <- data.frame( + SNP = paste0("rs", seq_len(d$M)), + CHR = "chr1", + BP = as.integer(seq_len(d$M) * 100L), + A1 = "A", + A2 = "G", + Z = z, + N = d$N + ) + GwasSumStats( + studyName = "sim", + entry = list(.dfToGwasGr(df)), + genome = "hg19", + ldReference = makeTestGwasGenotypeHandle() + ) +} + +# The reference each method reads. +.h2MethodRef <- function(d, method) { + if (method %in% c("lder", "hdl")) d$eigenRef else d$scoreRef +} + +# Score z of a random 30% candidate whose variants carry `enrich` times the +# per-variant heritability of the rest, for each method, over `nRep` traits. +.h2CandidateZ <- function( + d, + enrich, + nRep, + methods = c("sldsc", "gldsc", "lder", "hdl") +) { + t(replicate(nRep, { + cand <- stats::rbinom(d$M, 1, 0.3) + perSnp <- 0.3 / d$M * ifelse(cand == 1L, enrich, 1) + ss <- .h2ScoreSumstats(d, d$simZ(perSnp)) + annot <- .h2ScoreAnnot(d$M, cand) + vapply( + methods, + function(m) { + scoreStats(suppressWarnings(estimateH2( + ss, + .h2MethodRef(d, m), + method = m, + annotations = annot + )))$z + }, + numeric(1) + ) + })) +} + +test_that("candidate score z is calibrated under the null", { + d <- .h2RecoveryRefs(nBlocks = 20L) + set.seed(11) + z <- .h2CandidateZ(d, enrich = 1, nRep = 60L) + for (method in colnames(z)) { + expect_lt(abs(mean(z[, method])), 0.25) + expect_gt(stats::sd(z[, method]), 0.7) + expect_lt(stats::sd(z[, method]), 1.35) + } +}) + +test_that("candidate score z detects an enriched candidate", { + d <- .h2RecoveryRefs(nBlocks = 20L) + set.seed(12) + z <- .h2CandidateZ(d, enrich = 4, nRep = 15L) + expect_gt(mean(z[, "gldsc"]), 3) + # LDER and HDL read the same eigen-decomposition, and on this reference + # detect it less sharply than g-LDSC's GLS does. + expect_gt(mean(z[, "lder"]), 1.5) + expect_gt(mean(z[, "hdl"]), 1.5) + # S-LDSC spends its weight on the base score and so tests less sharply + # on a reference this small, but still points the right way. + expect_gt(mean(z[, "sldsc"]), 0.5) +}) + +# =========================================================================== +# The baseline design: an all-ones base column unless the baseline spans it +# =========================================================================== + +# A baseline of the given columns over the recovery reference. +.h2BaselineOf <- function(d, cols) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = as.integer(seq_len(d$M) * 100L), width = 1L) + ) + AnnotationMatrix( + cols, + gr, + data.frame(name = colnames(cols), tier = "baseline", type = "binary"), + genome = "hg19" + ) +} + +.h2FitAll <- function(d, ss, annotations) { + lapply( + set_names(c("lder", "hdl", "gldsc", "sldsc")), + function(m) { + suppressWarnings(estimateH2( + ss, + .h2MethodRef(d, m), + method = m, + annotations = annotations + )) + } + ) +} + +test_that("every estimator fits a lone annotation beside a base column", { + # One annotation and the partition it makes with its complement span the + # same designs once the base is added; without it, LDER and HDL used to + # model the uncovered half as carrying no heritability. + d <- .h2RecoveryRefs(nBlocks = 10L) + half <- as.integer(seq_len(d$M) <= d$M / 2) + set.seed(9) + ss <- .h2ScoreSumstats(d, d$simZ(ifelse(half == 1L, 0.5, 0.2) / d$M)) + lone <- .h2FitAll(d, ss, .h2BaselineOf(d, cbind(half = half))) + pair <- .h2FitAll( + d, + ss, + .h2BaselineOf(d, cbind(half = half, rest = 1L - half)) + ) + for (m in c("lder", "hdl")) { + expect_equal( + heritabilityEstimate(lone[[m]]), + heritabilityEstimate(pair[[m]]), + tolerance = 1e-3, + info = m + ) + lonePart <- stratifiedHeritabilityEnrichment(lone[[m]]) + pairPart <- stratifiedHeritabilityEnrichment(pair[[m]]) + expect_equal( + lonePart$enrichment, + pairPart$enrichment[pairPart$annotation == "half"], + tolerance = 1e-3, + info = m + ) + } + # Only the user's annotations are reported, never the added base. + for (m in names(lone)) { + expect_identical( + stratifiedHeritabilityEnrichment(lone[[m]])$annotation, + "half", + info = m + ) + } +}) + +test_that("an all-ones baseline fits as the unstratified model does", { + d <- .h2RecoveryRefs(nBlocks = 10L) + set.seed(9) + ss <- .h2ScoreSumstats(d, d$simZ(rep(0.35 / d$M, d$M))) + ones <- .h2FitAll(d, ss, .h2BaselineOf(d, cbind(ones = rep(1L, d$M)))) + none <- .h2FitAll(d, ss, NULL) + for (m in names(ones)) { + # S-LDSC's one design column is then the all-ones annotation's + # stratified score, formed from the LD, rather than the stored base + # score: the two agree to rounding of the LD. + expect_equal( + heritabilityEstimate(ones[[m]]), + heritabilityEstimate(none[[m]]), + tolerance = 1e-4, + info = m + ) + expect_equal( + stratifiedHeritabilityEnrichment(ones[[m]])$enrichment, + 1, + tolerance = 1e-6, + info = m + ) + } +}) + +test_that("HDL can estimate a depleted annotation", { + # Beside the base an annotation's parameter is its excess over the + # genome-wide rate; a lower bound of 0 used to forbid depletion. + d <- .h2RecoveryRefs(nBlocks = 10L) + half <- as.integer(seq_len(d$M) <= d$M / 2) + set.seed(4) + ss <- .h2ScoreSumstats(d, d$simZ(ifelse(half == 1L, 0.1, 0.6) / d$M)) + fit <- suppressWarnings(estimateH2( + ss, + d$eigenRef, + method = "hdl", + annotations = .h2BaselineOf(d, cbind(half = half)) + )) + part <- stratifiedHeritabilityEnrichment(fit) + expect_lt(part$tau, 0) + expect_lt(part$enrichment, 1) +}) + +test_that("S-LDSC's candidate score test needs the reference's LD", { + # The recovery reference's scores, without the LD they came from. + d <- .h2RecoveryRefs(nBlocks = 4L) + ref <- LdScore( + ldBlocks = ldBlocks(d$scoreRef), + snpInfo = data.frame( + SNP = paste0("rs", seq_len(d$M)), + CHR = "chr1", + BP = as.integer(seq_len(d$M) * 100L), + A1 = "A", + A2 = "G" + ), + nSamples = 500000L, + inSample = FALSE, + genome = "hg19", + ldScores = S4Vectors::mcols(d$scoreRef)$ldScores, + ldScoreWeights = rep(1, d$M) + ) + # Candidates only: the unstratified fit needs no LD, the score does. + cand <- matrix(stats::rbinom(d$M, 1, 0.3), dimnames = list(NULL, "cand")) + annot <- AnnotationMatrix( + cand, + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(as.integer(seq_len(d$M) * 100L), width = 1L) + ), + data.frame(name = "cand", tier = "candidate", type = "binary"), + genome = "hg19" + ) + expect_error( + estimateH2( + .h2ScoreSumstats(d, stats::rnorm(d$M)), + ref, + method = "sldsc", + annotations = annot + ), + "candidate-annotation score test needs each LD block's LD" + ) +}) + test_that("gldscUnivariate recovers a known h2 (deterministic, seed = 1)", { d <- .h2RecoveryRefs() uni <- rep(0.4 / d$M, d$M) @@ -2033,9 +2252,8 @@ test_that("partitioned S-LDSC reproduces the original ldsc to 1e-5", { ref <- .h2ParityRef()$score M <- length(ref) inA <- as.integer(seq_len(M) <= M / 2) - baselineMat <- matrix(inA, ncol = 1, dimnames = list(NULL, "annotA")) - scores <- pecotmr:::.sldscScoreMatrix(ref, baselineMat, M) A <- cbind(base = 1, annotA = inA) + scores <- pecotmr:::.sldscScoreMatrix(ref, A) reference <- list( list( @@ -2088,11 +2306,7 @@ test_that("the two S-LDSC routes differ, as the original ldsc's do", { inA <- as.integer(seq_len(M) <= M / 2) part <- pecotmr:::.sldscFit( z^2, - pecotmr:::.sldscScoreMatrix( - ref, - matrix(inA, ncol = 1, dimnames = list(NULL, "annotA")), - M - ), + pecotmr:::.sldscScoreMatrix(ref, cbind(base = 1, annotA = inA)), scores[, 1], 10000, cbind(base = 1, annotA = inA), @@ -2264,7 +2478,7 @@ test_that("the chi2 filter is abandoned when too few variants survive it", { ) expect_setequal( names(out), - c("tau", "h2", "estH", "intercept", "coef") + c("tau", "h2", "intercept", "coef") ) expect_false(is.na(out$h2)) }) @@ -2311,7 +2525,7 @@ test_that("the partitioned chi2 filter is abandoned when too few survive", { ) expect_setequal( names(out), - c("tau", "h2", "estH", "intercept", "coef") + c("tau", "h2", "intercept", "coef") ) }) @@ -2391,19 +2605,6 @@ test_that(".lderLocalBlock reports NA for a block too small to fit", { expect_true(is.na(out$h2LocalSe)) }) -test_that(".h2Enrichment names unnamed annotation columns positionally", { - baselineMat <- matrix(c(1, 0, 1, 1), nrow = 2L) - expect_null(colnames(baselineMat)) - out <- pecotmr:::.h2Enrichment( - baselineMat, - tau = c(0.1, 0.2), - tauSe = c(0.01, 0.02), - annotationJackknifeCoefs = matrix(c(0.1, 0.2, 0.1, 0.2), nrow = 2L), - h2 = 0.3 - ) - expect_equal(out$annotation, c("annot_1", "annot_2")) -}) - test_that(".sldscBlockIndex errors when no block covers a variant", { n <- 6L snpInfo <- data.frame( @@ -2455,7 +2656,7 @@ test_that(".sldscIrwls derives its own starting weights when none are given", { intercept = 1, w0 = NULL ) - expect_setequal(names(fit), c("coef", "intercept")) + expect_setequal(names(fit), c("coef", "intercept", "w")) expect_true(all(is.finite(fit$coef))) }) diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 28dd8846..7ce9434f 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -224,7 +224,7 @@ test_that("qtlEnrichmentPipeline: keys a QTL outcome side by its trait", { ldReference = .qep_makeHandle() ) local_mocked_bindings( - qtlEnrichment = .qep_mockEnrichment(2.0), + .qtlEnrichmentCoded = .qep_mockEnrichment(2.0), .package = "pecotmr" ) out <- qtlEnrichmentPipeline( @@ -239,7 +239,7 @@ test_that("qtlEnrichmentPipeline: keys a QTL outcome side by its trait", { test_that("qtlEnrichmentPipeline: pairs two GWAS collections", { local_mocked_bindings( - qtlEnrichment = .qep_mockEnrichment(2.0), + .qtlEnrichmentCoded = .qep_mockEnrichment(2.0), .package = "pecotmr" ) out <- qtlEnrichmentPipeline( @@ -261,7 +261,7 @@ test_that("qtlEnrichmentPipeline: a QTL outcome may carry no ldReference", { # The RSS-derived requirement is a GWAS-side contract; an individual-level # QTL outcome has no panel to check. local_mocked_bindings( - qtlEnrichment = .qep_mockEnrichment(2.0), + .qtlEnrichmentCoded = .qep_mockEnrichment(2.0), .package = "pecotmr" ) out <- qtlEnrichmentPipeline( @@ -339,7 +339,7 @@ test_that("qtlEnrichmentPipeline: returns one row per (gwasStudy, qtlStudy, qtlC gfmr <- .qep_makeGwasFmr() qfmr <- .qep_makeQtlFmr(contexts = c("c1", "c2")) local_mocked_bindings( - qtlEnrichment = .qep_mockEnrichment(2.0), + .qtlEnrichmentCoded = .qep_mockEnrichment(2.0), .package = "pecotmr" ) out <- qtlEnrichmentPipeline( @@ -372,7 +372,7 @@ test_that("qtlEnrichmentPipeline: distinguishes two QTL studies that share a con gfmr <- .qep_makeGwasFmr() capturedRegions <- list() local_mocked_bindings( - qtlEnrichment = function(gwasPip, susieQtlRegions, ...) { + .qtlEnrichmentCoded = function(gwasPip, susieQtlRegions, ...) { capturedRegions[[length(capturedRegions) + 1L]] <<- susieQtlRegions .qep_mockEnrichment(2.0)() }, @@ -393,7 +393,7 @@ test_that("qtlEnrichmentPipeline: qtlEnrichment failure produces a warning + ski gfmr <- .qep_makeGwasFmr() qfmr <- .qep_makeQtlFmr() local_mocked_bindings( - qtlEnrichment = function(...) stop("synthetic failure"), + .qtlEnrichmentCoded = function(...) stop("synthetic failure"), .package = "pecotmr" ) expect_warning( @@ -509,11 +509,117 @@ test_that(".enrBuildGwasPipVector: conflicting PIPs across blocks errors", { ldReference = .qep_makeHandle() ) expect_error( - pecotmr:::.enrBuildGwasPipVector(g, .qep_gwasIdent("G1")), + pecotmr:::.enrBuildGwasPipVector(g, .qep_gwasIdent("G1"), "error"), "conflicting PIPs" ) }) +# =========================================================================== +# qtlEnrichmentPipeline(): a variant repeated across GWAS blocks +# =========================================================================== + +# Two GWAS blocks sharing their boundary variant chr1:200, to which each +# block's fit gives its own PIP. `region` gives the blocks' windows. +.qep_boundaryGwasFmr <- function(region = NULL, pips = c(0.3, 0.6)) { + e1 <- .qep_makeFmEntry( + variant_ids = c("chr1:100:A:G", "chr1:200:A:G"), + pip = c(0.5, pips[[1L]]) + ) + e2 <- .qep_makeFmEntry( + variant_ids = c("chr1:200:A:G", "chr1:300:A:G"), + pip = c(pips[[2L]], 0.1) + ) + GwasFineMappingResult( + studyName = c("G1", "G1"), + method = c("susie", "susie"), + entry = list(e1, e2), + region = region, + ldReference = .qep_makeHandle() + ) +} + +.qep_windows <- function(starts, ends) { + GenomicRanges::GRanges("chr1", IRanges::IRanges(starts, ends)) +} + +# The GWAS PIP vector qtlEnrichmentPipeline() hands the estimator. +.qep_capturedGwasPip <- function(gwasFmr, ...) { + captured <- NULL + mock <- .qep_mockEnrichment() + local_mocked_bindings( + .qtlEnrichmentCoded = function(gwasPip, susieQtlRegions, ...) { + # The pipeline hands the PIPs with their variants; named here as + # the variants' ids. + variants <- list(...)$gwasVariants + captured <<- set_names( + gwasPip, + pecotmr:::.variantTableIds(variants) + ) + mock(gwasPip, susieQtlRegions, ...) + }, + .package = "pecotmr" + ) + qtlEnrichmentPipeline(gwasFmr, .qep_makeQtlFmr(), verbose = FALSE, ...) + captured +} + +test_that("qtlEnrichmentPipeline: keeps the largest of conflicting PIPs", { + pip <- .qep_capturedGwasPip(.qep_boundaryGwasFmr()) + expect_equal( + pip, + c(`chr1:100:A:G` = 0.5, `chr1:200:A:G` = 0.6, `chr1:300:A:G` = 0.1) + ) +}) + +test_that("qtlEnrichmentPipeline: duplicatePips = 'error' refuses conflicts", { + expect_error( + .qep_capturedGwasPip(.qep_boundaryGwasFmr(), duplicatePips = "error"), + "'chr1:200:A:G' appears with conflicting PIPs" + ) + expect_error( + .qep_capturedGwasPip(.qep_boundaryGwasFmr(), duplicatePips = "first"), + "must be one of" + ) +}) + +test_that("qtlEnrichmentPipeline: 'blockEnd' keeps the block ending at the variant", { + # The upstream block's window ends at chr1:200; the downstream one starts + # there. + pip <- .qep_capturedGwasPip( + .qep_boundaryGwasFmr(.qep_windows(c(1, 200), c(200, 400))), + duplicatePips = "blockEnd" + ) + expect_equal(pip[["chr1:200:A:G"]], 0.3) + expect_length(pip, 3L) +}) + +test_that("qtlEnrichmentPipeline: 'blockEnd' refuses a copy it cannot choose", { + # No window given, or none ending at the variant: nothing to decide by. + for (region in list(NULL, .qep_windows(c(1, 150), c(250, 400)))) { + expect_error( + .qep_capturedGwasPip( + .qep_boundaryGwasFmr(region), + duplicatePips = "blockEnd" + ), + "cannot choose between them: 0 of its blocks" + ) + } +}) + +test_that("qtlEnrichmentPipeline: agreeing copies merge under every policy", { + for (policy in c("max", "error", "blockEnd")) { + pip <- .qep_capturedGwasPip( + .qep_boundaryGwasFmr(pips = c(0.3, 0.3)), + duplicatePips = policy + ) + expect_equal( + pip, + c(`chr1:100:A:G` = 0.5, `chr1:200:A:G` = 0.3, `chr1:300:A:G` = 0.1), + info = policy + ) + } +}) + test_that(".enrBuildQtlRegionsList: returns per-entry fit shapes for a (study, context) hit", { qfmr <- .qep_makeQtlFmr(contexts = c("c1", "c2")) out <- pecotmr:::.enrBuildQtlRegionsList(qfmr, .qep_qtlIdent("Q1", "c1")) @@ -680,6 +786,7 @@ test_that("qtlEnrichment: errors when piGwas resolves to zero", { qtlEnrichment( gwasPip = zeroGwas, susieQtlRegions = fx$susieQtlRegions, + numGwas = 5000, piQtl = 0.5, BPPARAM = BiocParallel::SerialParam(), verbose = FALSE @@ -768,6 +875,721 @@ test_that("qtlEnrichment: tracks unmatched QTL variants, either alignNames", { }) +# One-hot QTL fixtures for the enrichment kernel. Every alpha row puts all of +# its mass on one variant, so each imputation round samples the same variants +# whatever the random stream: the estimates are exactly reproducible, and do +# not depend on how a standard library implements std::discrete_distribution. + +.qeh_ids <- function(n = 200L) { + sprintf("chr1:%d:A:G", 100L * seq_len(n)) +} + +# A GWAS PIP vector over .qeh_ids(): background 0.001, with high PIPs on the +# last ten variants. +.qeh_gwasPip <- function() { + stats::setNames( + c( + rep(0.001, 190), + 0.9, + 0.8, + 0.5, + 0.3, + 0.2, + 0.1, + 0.05, + 0.02, + 0.01, + 0.6 + ), + .qeh_ids() + ) +} + +# A region over variants `idx` of the GWAS panel whose effects each sit on the +# variant at position `hits[l]` within the region. `ids` relabels the region's +# variants, e.g. to put some outside the GWAS panel. +.qeh_oneHotRegion <- function( + idx, + hits, + priorVariance = c(0.5, 0.2)[seq_along(hits)], + ids = .qeh_ids()[idx] +) { + alpha <- matrix(0, length(hits), length(idx)) + alpha[cbind(seq_along(hits), hits)] <- 1 + list( + alpha = alpha, + pip = stats::setNames(as.numeric(colSums(alpha) > 0), ids), + prior_variance = priorVariance + ) +} + +# Three regions: r1's effects sit on variants 191 (GWAS PIP 0.9) and 152, r2's +# on 192 (0.8) and 195 (0.2), r3's on two background variants. +.qeh_oneHotRegions <- function() { + list( + r1 = .qeh_oneHotRegion(150:200, c(42, 3)), + r2 = .qeh_oneHotRegion(170:200, c(23, 26)), + r3 = .qeh_oneHotRegion(1:60, c(5, 40)) + ) +} + +# =========================================================================== +# qtlEnrichment(): pinned estimates, null fits, fit validation, threads +# Built on the one-hot fixtures above, whose sampling is +# deterministic. +# =========================================================================== + +.qep_oneHotRun <- function( + regions = .qeh_oneHotRegions(), + numGwas = 5000, + piQtl = 0.01, + ... +) { + qtlEnrichment( + .qeh_gwasPip(), + regions, + numGwas = numGwas, + piQtl = piQtl, + impN = 3, + seed = 1L, + verbose = FALSE, + ... + ) +} + +test_that("qtlEnrichment: one-hot fixture reproduces the pinned estimates", { + # Recorded from the kernel before its fits were integer-coded and null + # fits allowed. Without shrinkage the shrunk and unshrunk a1 coincide. + pinned <- c( + `Intercept` = -21.896577386392181, + `sd (intercept)` = 11.186832846318783, + `Enrichment (no shrinkage)` = 19.284745626108926, + `Enrichment (w/ shrinkage)` = 19.284745626108926, + `sd (no shrinkage)` = 13.735002410315799, + `sd (w/ shrinkage)` = 13.735002410315799, + `Alternative (coloc) p1` = 3.0624743716206618e-10, + `Alternative (coloc) p2` = 0.0093161918064975369, + `Alternative (coloc) p12` = 0.00068380819350246172, + `Effective MI rounds` = 3 + ) + res <- .qep_oneHotRun(lambda = 0) + expect_equal(unlist(res[names(pinned)]), pinned, tolerance = 1e-10) +}) + +test_that("qtlEnrichment: one-hot fixture reproduces the pinned shrunk a1", { + keys <- c( + "Enrichment (no shrinkage)", + "Enrichment (w/ shrinkage)", + "sd (no shrinkage)", + "sd (w/ shrinkage)" + ) + single <- .qep_oneHotRun(lambda = 1) + double <- .qep_oneHotRun( + lambda = 1, + doubleShrinkage = TRUE, + besselCorrection = FALSE + ) + expect_equal( + unname(unlist(single[keys])), + c( + 19.284745626108926, + 0.10168582132370414, + 13.735002410315799, + 0.99736008393071596 + ), + tolerance = 1e-10 + ) + expect_equal( + unname(unlist(double[keys])), + c( + 19.284745626108926, + 0.050977308844208112, + 13.735002410315799, + 0.70617157949200415 + ), + tolerance = 1e-10 + ) +}) + +test_that("qtlEnrichment: a null QTL fit samples nothing instead of aborting", { + keys <- c( + "Intercept", + "Enrichment (no shrinkage)", + "sd (no shrinkage)", + "Alternative (coloc) p12" + ) + base <- .qep_oneHotRun(lambda = 0) + # Every effect of prior variance 0: the kernel used to stop on this. + nullFit <- .qeh_oneHotRegion(61:80, c(1, 2), priorVariance = c(0, 0)) + res <- .qep_oneHotRun( + c(.qeh_oneHotRegions(), list(n = nullFit)), + lambda = 0 + ) + expect_equal(unlist(res[keys]), unlist(base[keys])) + expect_equal(res[["Null QTL fits"]], 1L) + # A fit already trimmed to its non-null effects has a 0-row alpha. + trimmed <- list( + alpha = matrix(0, 0L, 3L), + pip = stats::setNames(rep(0, 3), .qeh_ids()[61:63]), + prior_variance = numeric(0) + ) + res <- .qep_oneHotRun( + c(.qeh_oneHotRegions(), list(n = trimmed)), + lambda = 0 + ) + expect_equal(unlist(res[keys]), unlist(base[keys])) +}) + +test_that("qtlEnrichment: refuses a tuple made only of null fits", { + nullFit <- .qeh_oneHotRegion(1:10, c(1, 2), priorVariance = c(0, 0)) + expect_error(.qep_oneHotRun(list(a = nullFit)), "nothing to sample") +}) + +test_that("qtlEnrichment: refuses malformed fits, naming them", { + ok <- .qeh_oneHotRegion(1:10, c(1, 2)) + run <- function(bad) .qep_oneHotRun(list(good = ok, bad = bad)) + # A null_weight fit carries one more alpha column than it has variants. + extraColumn <- ok + extraColumn$alpha <- cbind(ok$alpha, 0) + expect_error(run(extraColumn), "bad: alpha has 11 columns for 10 pip") + shortV <- ok + shortV$prior_variance <- 0.5 + expect_error(run(shortV), "bad: alpha has 2 rows for 1 prior variances") + infV <- ok + infV$prior_variance <- c(Inf, 0.2) + expect_error(run(infV), "bad: prior variances must be finite") + nanAlpha <- ok + nanAlpha$alpha[1, 2] <- NaN + expect_error(run(nanAlpha), "bad: alpha must be finite and non-negative") + negativeAlpha <- ok + negativeAlpha$alpha[1, 1:2] <- c(1.1, -0.1) + expect_error( + run(negativeAlpha), + "bad: alpha must be finite and non-negative" + ) + offSum <- ok + offSum$alpha[1, ] <- offSum$alpha[1, ] / 2 + expect_error(run(offSum), "bad: an alpha row of positive prior variance") +}) + +test_that("qtlEnrichment: estimates do not depend on the thread count", { + skip_on_os("windows") + fx <- .qep_makeRealKernelInputs() + run <- function(bp) { + qtlEnrichment( + fx$gwasPip, + fx$susieQtlRegions, + numGwas = 5000, + piQtl = 0.5, + impN = 6, + BPPARAM = bp, + seed = 7L, + verbose = FALSE + ) + } + expect_identical( + run(BiocParallel::SerialParam()), + run(BiocParallel::MulticoreParam(2)) + ) +}) + +test_that("qtlEnrichment: verbose = FALSE is silent", { + expect_silent(.qep_oneHotRun()) +}) + +test_that("qtlEnrichment: reports per-round diagnostics", { + # r4's second effect sits on a variant the GWAS vector does not carry: + # one of the eight variants sampled each round. + r4 <- .qeh_oneHotRegion( + 1:10, + c(3, 7), + ids = c(.qeh_ids()[1:5], sprintf("chr2:%d:C:T", 1:5)) + ) + regions <- c(.qeh_oneHotRegions(), list(r4 = r4)) + res <- .qep_oneHotRun(regions, lambda = 0) + expect_equal(res[["Missing proportion per MI round"]], rep(1 / 8, 3)) + expect_identical(res[["EM converged per MI round"]], rep(TRUE, 3)) + expect_identical(res[["Null QTL fits"]], 0L) + expect_identical( + res$unused_xqtl_variants$r4, + sprintf("chr2:%d:C:T", 1:5) + ) + expect_null(res$unused_xqtl_variants$r1) + msgs <- testthat::capture_messages(qtlEnrichment( + .qeh_gwasPip(), + regions, + numGwas = 5000, + piQtl = 0.01, + impN = 3, + seed = 1L, + verbose = TRUE + )) + expect_match( + paste(msgs, collapse = ""), + "missing from the GWAS PIP vector: 0.125" + ) +}) + +# An R transcription of fastenloc's enrichment estimator +# (github.com/xqwen/fastenloc, src/controller.cc: run_EM and the +# multiple-imputation post-processing of enrich_est), to check the C++ kernel +# against the original method. It takes the variants each imputation round +# samples directly, so a test can feed it what a one-hot fixture (above) +# makes every round of the kernel sample. + +# One round's EM. `gwasPip` and `eqtlSample` run over every variant fastenloc +# reads, GWAS and QTL alike; a QTL variant the GWAS file lacks has GWAS PIP 0. +.flr_runEm <- function(gwasPip, eqtlSample, pGwas, pEqtl, totalSnp) { + a0 <- log(pGwas / (1 - pGwas)) + a1 <- 0 + r0 <- exp(a0) + r1 <- exp(a0 + a1) + rm <- pGwas / (1 - pGwas) + val <- gwasPip + val[val == 1] <- 1 - 1e-8 + odds <- val / (1 - val) + sampled <- eqtlSample == 1 + repeat { + e0g0 <- (1 - pGwas) * (1 - pEqtl) + e0g1 <- (1 - pEqtl) * pGwas + e1g0 <- (1 - pGwas) * pEqtl + e1g1 <- pGwas * pEqtl + post0 <- r0 * (odds[!sampled] / rm) + post0 <- post0 / (1 + post0) + post1 <- r1 * (odds[sampled] / rm) + post1 <- post1 / (1 + post1) + e0g1 <- e0g1 + sum(post0) + e0g0 <- e0g0 + sum(1 - post0) + e1g1 <- e1g1 + sum(post1) + e1g0 <- e1g0 + sum(1 - post1) + e0g0 <- e0g0 + totalSnp - (e0g0 + e0g1 + e1g0 + e1g1) + a1New <- log(e1g1 * e0g0 / (e1g0 * e0g1)) + if (abs(a1New - a1) < 0.01) { + # fastenloc keeps the previous iteration's a0 here. + return(c( + a0 = a0, + a1 = a1New, + v0 = 1 / e0g1 + 1 / e0g0, + v1 = 1 / e0g0 + 1 / e1g0 + 1 / e1g1 + 1 / e0g1 + )) + } + a1 <- a1New + a0 <- log(e0g1 / e0g0) + r0 <- exp(a0) + r1 <- exp(a0 + a1) + } +} + +# The post-processing of the rounds' estimates (a matrix with rows a0, a1, v0, +# v1): outlier removal on the shrunk a1, which fastenloc's command line always +# applies; Rubin's rules; the intercept from the unshrunk a1; double +# shrinkage; and the coloc priors from the intercept and the shrunk a1. +# `lambda` is fastenloc's -s, where 0 means no shrinkage (a prior variance of +# 1e16). fastenloc takes the outliers' population sd in one pass; two passes +# give the same value without its cancellation. +.flr_combine <- function(rounds, pGwas, pEqtl, lambda) { + pv <- if (lambda == 0) 1e16 else 1 / lambda + shrunk <- rounds["a1", ] * pv / (pv + rounds["v1", ]) + mu <- mean(shrunk) + sdev <- sqrt(mean((shrunk - mu)^2)) + rounds <- rounds[, !(abs(shrunk - mu) > 3 * sdev), drop = FALSE] + m <- ncol(rounds) + a0 <- rounds["a0", ] + a1 <- rounds["a1", ] + v1 <- rounds["v1", ] + postA1 <- a1 * pv / (pv + v1) + postVar <- 1 / (1 / pv + 1 / v1) + sd0 <- sqrt(mean(rounds["v0", ]) + stats::var(a0) * (m + 1) / m) + sd1 <- sqrt(mean(v1) + stats::var(a1) * (m + 1) / m) + sd1Shrink <- sqrt(mean(postVar) + stats::var(postA1) * (m + 1) / m) + intercept <- log(pGwas / (1 + pEqtl * exp(mean(a1)) - pEqtl - pGwas)) + a1Shrink <- pv * mean(postA1) / (pv + sd1Shrink^2) + sd1Shrink <- sqrt(1 / (1 / pv + 1 / sd1Shrink^2)) + c( + `Intercept` = intercept, + `sd (intercept)` = sd0, + `Enrichment (no shrinkage)` = mean(a1), + `Enrichment (w/ shrinkage)` = a1Shrink, + `sd (no shrinkage)` = sd1, + `sd (w/ shrinkage)` = sd1Shrink, + `Alternative (coloc) p1` = (1 - pEqtl) * + exp(intercept) / + (1 + exp(intercept)), + `Alternative (coloc) p2` = pEqtl / (1 + exp(intercept + a1Shrink)), + `Alternative (coloc) p12` = pEqtl * + exp(intercept + a1Shrink) / + (1 + exp(intercept + a1Shrink)), + `Effective MI rounds` = m + ) +} + +# fastenloc on qtlEnrichment()'s inputs, every round sampling the variant ids +# `sampled`. Its variants are the GWAS ones plus the QTL ones they lack, its +# total is -total_variants raised to their number, and its priors are the +# GWAS and QTL PIP mass over that total. +.flr_reference <- function( + gwasPip, + regions, + sampled, + numGwas = NULL, + lambda = 1, + impN = 3 +) { + qtlIds <- unique(unlist( + lapply(regions, function(x) names(x$pip)), + use.names = FALSE + )) + variants <- c(names(gwasPip), setdiff(qtlIds, names(gwasPip))) + pip <- c(unname(gwasPip), rep(0, length(variants) - length(gwasPip))) + totalSnp <- max(if (is.null(numGwas)) 0 else numGwas, length(variants)) + pGwas <- sum(gwasPip) / totalSnp + pEqtl <- sum(unlist(lapply(regions, `[[`, "pip"))) / totalSnp + round <- .flr_runEm( + pip, + as.integer(variants %in% sampled), + pGwas, + pEqtl, + totalSnp + ) + rounds <- matrix( + round, + nrow = length(round), + ncol = impN, + dimnames = list(names(round), NULL) + ) + .flr_combine(rounds, pGwas, pEqtl, lambda) +} + +# The variants every round samples from one-hot regions: the hit of each +# effect with positive prior variance. +.flr_oneHotSamples <- function(regions) { + unlist( + lapply(regions, function(x) { + alpha <- x$alpha[x$prior_variance > 0, , drop = FALSE] + names(x$pip)[max.col(alpha, ties.method = "first")] + }), + use.names = FALSE + ) +} + +# =========================================================================== +# qtlEnrichment(): fastenloc semantics +# Checked against the R transcription of fastenloc above. fastenloc's EM keeps the previous iteration's +# intercept at convergence, so only sd (intercept) is not compared. +# =========================================================================== + +# The one-hot regions plus r4, whose effects sit on a GWAS variant and on +# chr2:2, a variant the GWAS vector lacks; chr2:1 and chr2:3-5 are QTL-only +# variants no round samples. +.qep_qtlOnlyRegions <- function() { + r4 <- .qeh_oneHotRegion( + 1:10, + c(3, 7), + ids = c(.qeh_ids()[1:5], sprintf("chr2:%d:C:T", 1:5)) + ) + c(.qeh_oneHotRegions(), list(r4 = r4)) +} + +.qep_parityKeys <- function() { + c( + "Intercept", + "Enrichment (no shrinkage)", + "Enrichment (w/ shrinkage)", + "sd (no shrinkage)", + "sd (w/ shrinkage)", + "Alternative (coloc) p1", + "Alternative (coloc) p2", + "Alternative (coloc) p12", + "Effective MI rounds" + ) +} + +test_that("qtlEnrichment: matches fastenloc, QTL-only variants included", { + keys <- .qep_parityKeys() + for (regions in list(.qeh_oneHotRegions(), .qep_qtlOnlyRegions())) { + for (numGwas in list(5000, NULL)) { + for (lambda in c(1, 0.5, 0)) { + info <- paste0( + length(regions), + " regions, numGwas = ", + deparse(numGwas), + ", lambda = ", + lambda + ) + reference <- .flr_reference( + .qeh_gwasPip(), + regions, + .flr_oneHotSamples(regions), + numGwas = numGwas, + lambda = lambda + ) + res <- suppressWarnings(qtlEnrichment( + .qeh_gwasPip(), + regions, + numGwas = numGwas, + lambda = lambda, + impN = 3, + doubleShrinkage = TRUE, + besselCorrection = FALSE, + seed = 1L, + verbose = FALSE + )) + expect_equal( + unlist(res[keys]), + reference[keys], + tolerance = 1e-8, + info = info + ) + } + } + } +}) + +test_that("qtlEnrichment: the intercept uses the unshrunk enrichment", { + res <- .qep_oneHotRun(lambda = 1) + piGwas <- sum(.qeh_gwasPip()) / 5000 + a1 <- res[["Enrichment (no shrinkage)"]] + expect_equal( + res[["Intercept"]], + log(piGwas / (1 + 0.01 * exp(a1) - 0.01 - piGwas)) + ) + a01 <- res[["Intercept"]] + res[["Enrichment (w/ shrinkage)"]] + expect_equal(res[["Alternative (coloc) p12"]], 0.01 * plogis(a01)) +}) + +test_that("qtlEnrichment: a QTL-only variant counts as a GWAS PIP of 0", { + # Padding gwasPip with zeros for the QTL-only variants, at a fixed + # variant total, changes nothing but the diagnostics. + regions <- .qep_qtlOnlyRegions() + padded <- c( + .qeh_gwasPip(), + stats::setNames(rep(0, 5), sprintf("chr2:%d:C:T", 1:5)) + ) + keys <- c(.qep_parityKeys(), "sd (intercept)") + asGiven <- .qep_oneHotRun(regions, lambda = 1) + res <- qtlEnrichment( + padded, + regions, + numGwas = 5000, + piQtl = 0.01, + impN = 3, + seed = 1L, + verbose = FALSE + ) + expect_equal(unlist(res[keys]), unlist(asGiven[keys]), tolerance = 1e-10) + expect_equal(res[["Missing proportion per MI round"]], rep(0, 3)) + expect_equal(asGiven[["Missing proportion per MI round"]], rep(1 / 8, 3)) +}) + +test_that("qtlEnrichment: estimates do not depend on variant or region order", { + keys <- c(.qep_parityKeys(), "sd (intercept)") + regions <- .qep_qtlOnlyRegions() + base <- .qep_oneHotRun(regions, lambda = 1) + gwasPip <- .qeh_gwasPip() + res <- qtlEnrichment( + rev(gwasPip), + rev(regions), + numGwas = 5000, + piQtl = 0.01, + impN = 3, + seed = 1L, + verbose = FALSE + ) + expect_equal(unlist(res[keys]), unlist(base[keys]), tolerance = 1e-10) +}) + +test_that("qtlEnrichment: the variant total is the GWAS and QTL-only variants", { + regions <- .qep_qtlOnlyRegions() + # 200 GWAS variants and 5 QTL-only ones. + expect_warning( + res <- qtlEnrichment( + .qeh_gwasPip(), + regions, + piQtl = 0.01, + impN = 3, + seed = 1L, + verbose = FALSE + ), + "numGwas is not provided. Using the 205 distinct variants" + ) + at205 <- .qep_oneHotRun(regions, numGwas = 205) + keys <- .qep_parityKeys() + expect_equal(unlist(res[keys]), unlist(at205[keys])) + expect_warning( + below <- .qep_oneHotRun(regions, numGwas = 100), + "numGwas \\(100\\) is smaller than the 205 distinct variants" + ) + expect_equal(unlist(below[keys]), unlist(at205[keys])) +}) + +test_that("qtlEnrichment: piQtl defaults to the summed QTL PIPs over the total", { + regions <- .qep_qtlOnlyRegions() + expect_warning( + estimated <- qtlEnrichment( + .qeh_gwasPip(), + regions, + numGwas = 5000, + impN = 3, + seed = 1L, + verbose = FALSE + ), + "piQtl is not provided" + ) + # Four regions of two one-hot effects: 8 units of PIP. + supplied <- .qep_oneHotRun(regions, piQtl = 8 / 5000) + keys <- c(.qep_parityKeys(), "sd (intercept)") + expect_equal(unlist(estimated[keys]), unlist(supplied[keys])) +}) + +test_that("qtlEnrichment: refuses priors that do not sum to below 1", { + expect_error( + .qep_oneHotRun(piQtl = 0.9999), + "must sum to less than 1. Supply numGwas" + ) +}) + +test_that("qtlEnrichment: refuses a variant total too small for the data", { + # Every GWAS variant is sampled, so no variant is left that is neither + # QTL nor causal: the EM's (0, 0) cell is negative. + ids <- .qeh_ids(2L) + fit <- list( + alpha = diag(2), + pip = stats::setNames(c(1, 1), ids), + prior_variance = c(0.5, 0.2) + ) + expect_error( + suppressWarnings(qtlEnrichment( + stats::setNames(c(0.5, 0.5), ids), + list(a = fit), + piQtl = 0.1, + impN = 3, + seed = 1L, + verbose = FALSE + )), + "variant total is too small for the data in 3 of 3 MI round" + ) +}) + +# =========================================================================== +# qtlEnrichment(): aligning QTL variant names to the GWAS vector +# =========================================================================== + +# `regions` with the pip names at positions `at` of region `name` replaced. +.qep_renameIds <- function(regions, name, at, ids) { + nm <- names(regions[[name]]$pip) + nm[at] <- ids + names(regions[[name]]$pip) <- nm + regions +} + +.qep_estimates <- function(res) { + unlist(res[c(.qep_parityKeys(), "sd (intercept)")]) +} + +test_that("qtlEnrichment: aligns swapped and reformatted QTL ids to GWAS ids", { + regions <- .qeh_oneHotRegions() + # r1's effects sit on chr1:19100 and chr1:15200 (positions 42 and 3), + # r2's first on chr1:19200 (position 23). + renamed <- .qep_renameIds( + regions, + "r1", + c(42, 3), + c("chr1:19100:G:A", "1_15200_A_G") + ) + renamed <- .qep_renameIds(renamed, "r2", 23, "chr1:19200:G:A") + base <- .qep_oneHotRun(regions) + aligned <- .qep_oneHotRun(renamed) + expect_equal(.qep_estimates(aligned), .qep_estimates(base)) + expect_true(all(vapply(aligned$unused_xqtl_variants, is.null, TRUE))) + # Unaligned, the three names match nothing and count as QTL-only. + unaligned <- .qep_oneHotRun(renamed, alignNames = FALSE) + expect_setequal( + unlist(unaligned$unused_xqtl_variants), + c("chr1:19100:G:A", "1_15200_A_G", "chr1:19200:G:A") + ) + expect_false(isTRUE(all.equal( + .qep_estimates(unaligned), + .qep_estimates(base) + ))) +}) + +test_that("qtlEnrichment: an unparseable id leaves the others allele-aware", { + # An rsID among a tuple's names used to turn the whole match into exact + # string identity, leaving the swapped ids unmatched. + withRsid <- .qep_renameIds(.qeh_oneHotRegions(), "r1", 10, "rs999") + swapped <- .qep_renameIds(withRsid, "r1", 42, "chr1:19100:G:A") + res <- .qep_oneHotRun(swapped) + expect_identical(res$unused_xqtl_variants$r1, "rs999") + expect_equal( + .qep_estimates(res), + .qep_estimates(.qep_oneHotRun(withRsid)) + ) +}) + +test_that("qtlEnrichment: an exactly spelled GWAS id beats a swapped twin", { + # The GWAS vector carries chr1:19100 in both orientations, with + # different PIPs; each QTL spelling must take its own. + gwasPip <- c(.qeh_gwasPip(), `chr1:19100:G:A` = 0.05) + run <- function(regions, alignNames) { + qtlEnrichment( + gwasPip, + regions, + numGwas = 5000, + piQtl = 0.01, + impN = 3, + seed = 1L, + verbose = FALSE, + alignNames = alignNames + ) + } + regions <- .qeh_oneHotRegions() + swapped <- .qep_renameIds(regions, "r1", 42, "chr1:19100:G:A") + for (x in list(regions, swapped)) { + expect_equal( + .qep_estimates(run(x, TRUE)), + .qep_estimates(run(x, FALSE)) + ) + } + expect_false(isTRUE(all.equal( + .qep_estimates(run(regions, TRUE)), + .qep_estimates(run(swapped, TRUE)) + ))) +}) + +test_that("qtlEnrichment: matches a tuple's ids allele-aware in one call", { + calls <- 0L + local_mocked_bindings( + .matchVariantTables = function(a, b, ...) { + calls <<- calls + 1L + list(idxA = integer(0), idxB = integer(0), sign = numeric(0)) + }, + .package = "pecotmr" + ) + # Every name spelled as a GWAS id: nothing is left to match. + .qep_oneHotRun() + expect_identical(calls, 0L) + # Swapped ids in all three regions: one call for the tuple. + renamed <- .qep_renameIds(.qeh_oneHotRegions(), "r1", 42, "chr1:19100:G:A") + renamed <- .qep_renameIds(renamed, "r2", 26, "chr1:19500:G:A") + renamed <- .qep_renameIds(renamed, "r3", 5, "chr1:500:G:A") + .qep_oneHotRun(renamed) + expect_identical(calls, 1L) +}) + +test_that("qtlEnrichment: refuses gwasPip naming a variant twice", { + gwasPip <- .qeh_gwasPip() + expect_error( + qtlEnrichment( + c(gwasPip, gwasPip[1]), + .qeh_oneHotRegions(), + numGwas = 5000, + piQtl = 0.01, + verbose = FALSE + ), + "names variant 'chr1:100:A:G' more than once" + ) +}) + # =========================================================================== # qtlEnrichment(): verbose messages # =========================================================================== @@ -972,7 +1794,7 @@ test_that("qtlEnrichmentPipeline: alignTuple cache is reused across GWAS studies ) qfmr <- .qep_makeQtlFmr() local_mocked_bindings( - qtlEnrichment = .qep_mockEnrichment(2.0), + .qtlEnrichmentCoded = .qep_mockEnrichment(2.0), .package = "pecotmr" ) out <- qtlEnrichmentPipeline( @@ -1021,9 +1843,10 @@ test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { expect_warning( out <- pecotmr:::.enrRunEnrichment( 1L, - gwasPip = NULL, + outcome = NULL, + outcomeAt = NULL, k = 1L, - alignedByTuple = list(cnd), + prep = list(aligned = list(cnd), annotations = list(NULL)), qtlEnrichmentParam = QtlEnrichmentParam(), BPPARAM = BiocParallel::SerialParam(), seed = NULL, @@ -1043,8 +1866,7 @@ test_that(".enrBuildQtlRegionsList reads prior variance under either name", { run <- function(fit) { local_mocked_bindings( .enrMatchRows = function(qtlFmr, ident) 1L, - .fmrRowParts = function(qtlFmr, i) "parts", - susieFit = function(parts) fit, + .fmrFitsAt = function(x, idx) list(fit), .package = "pecotmr" ) pecotmr:::.enrBuildQtlRegionsList("fmr", "ident") @@ -1140,7 +1962,7 @@ test_that("qtlEnrichmentPipeline keeps each fine-mapping method's fits apart", { seen <- new.env() seen$regions <- integer(0) local_mocked_bindings( - qtlEnrichment = function(gwasPip, susieQtlRegions, ...) { + .qtlEnrichmentCoded = function(gwasPip, susieQtlRegions, ...) { seen$regions <- c(seen$regions, length(susieQtlRegions)) .qep_mockEnrichment(2.0)(gwasPip, susieQtlRegions, ...) }, @@ -1175,7 +1997,7 @@ test_that("qtlEnrichmentPipeline keeps each fine-mapping method's fits apart", { test_that("enrichment names a narrowed row's PIPs by its fit's variants", { vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") pip <- c(0.5, 0.3, 0.2) - fit <- list(pip = pip, alpha = matrix(pip, 1L), V = 1) + fit <- list(pip = set_names(pip, vids), alpha = matrix(pip, 1L), V = 1) tl <- data.frame(variant_id = vids, pip = pip) row <- FineMappingRow(vids, fit, tl) gwas <- GwasFineMappingResult( @@ -1197,6 +2019,22 @@ test_that("enrichment names a narrowed row's PIPs by its fit's variants", { region <- pecotmr:::.enrRowRegion(1L, endoapply(qtl, utils::head, 2L)) expect_equal(region$pip, set_names(pip, vids)) expect_equal(region$prior_variance, 1) + # A narrowed row whose fit names none has nothing to name them by. + unnamed <- QtlFineMappingResult( + studyName = "q1", + context = "c1", + trait = "g1", + method = "susie", + entry = list(FineMappingRow( + vids, + list(pip = pip, alpha = fit$alpha, V = 1), + tl + )) + ) + expect_error( + pecotmr:::.enrRowRegion(1L, endoapply(unnamed, utils::head, 2L)), + "does not name its variables" + ) }) test_that("qtlEnrichmentPipeline warns about narrowed fits on both sides", { @@ -1220,3 +2058,101 @@ test_that("qtlEnrichmentPipeline warns about narrowed fits on both sides", { "qtlEnrichmentPipeline\\(\\): 2 row\\(s\\)" ) }) + +# =========================================================================== +# Regions as the kernel reads them +# =========================================================================== + +test_that(".enrRenamePip renames a named pip and leaves an unnamed one", { + unnamed <- list(pip = c(0.4, 0.6)) + expect_identical(pecotmr:::.enrRenamePip(unnamed, c("a", "b")), unnamed) + named <- list(pip = c(x = 0.4, y = 0.6)) + expect_identical( + names(pecotmr:::.enrRenamePip(named, c("a", "b"))$pip), + c("a", "b") + ) +}) + +test_that(".enrCodeAligned codes an absent variant by the union's variant", { + # Variables 2 and 3 are one variant, spelled with its alleles swapped: the + # outcome lacks it and the union holds it (row 2), so both take one code. + # Variable 4 is in neither and keeps a code of its own. + annotation <- list( + regions = list( + r1 = list( + alpha = matrix(0.25, 1L, 4L), + prior_variance = 1 + ) + ), + table = list( + chrom = rep("chr1", 4L), + pos = c(100L, 200L, 200L, 300L), + A2 = c("A", "C", "T", "G"), + A1 = c("G", "T", "C", "A") + ), + n = 4L + ) + union <- list( + chrom = c("chr1", "chr1"), + pos = c(100L, 200L), + A2 = c("A", "C"), + A1 = c("G", "T") + ) + coded <- pecotmr:::.enrCodeAligned( + annotation, + outcomeIdx = c(1L, NA, NA, NA), + unionIdx = c(1L, 2L, 2L, NA), + unionTable = union + ) + expect_identical(coded$fits[[1L]]$codes, c(0L, -1L, -1L, -2L)) + expect_identical(coded$nQtlOnly, 2L) +}) + +test_that(".enrCodedFit hands the kernel double alpha and integer codes", { + fit <- pecotmr:::.enrCodedFit( + list(alpha = matrix(1L, 1L, 2L), prior_variance = 1L), + c(0, 1) + ) + expect_type(fit$alpha, "double") + expect_identical(dim(fit$alpha), c(1L, 2L)) + expect_type(fit$prior_variance, "double") + expect_identical(fit$codes, c(0L, 1L)) +}) + +test_that(".enrValidateFits names a fit whose alpha is not a numeric matrix", { + expect_error( + pecotmr:::.enrValidateFits(list( + gene1 = list(alpha = "a", pip = 1, prior_variance = 1) + )), + "gene1: alpha is not a numeric matrix" + ) +}) + +test_that(".enrReportDiagnostics warns of unconverged rounds, reports the rest", { + en <- list( + `EM converged per MI round` = c(TRUE, FALSE), + `Missing proportion per MI round` = c(0.1, 0.3), + `EM iterations per MI round` = c(10L, 1000L), + `Effective MI rounds` = 1L + ) + expect_warning( + msgs <- testthat::capture_messages(pecotmr:::.enrReportDiagnostics( + en, + nullFits = 1L, + nFits = 3L, + verbose = TRUE + )), + "did not converge within 1000 iterations in 1 of 2" + ) + shown <- paste(msgs, collapse = "") + expect_match(shown, "1 of 3 QTL fits have no effect") + expect_match(shown, "Outlier filtering removed 1 MI round") + # Quietly, the warning alone. + expect_warning( + quiet <- testthat::capture_messages( + pecotmr:::.enrReportDiagnostics(en, 1L, 3L, verbose = FALSE) + ), + "did not converge" + ) + expect_length(quiet, 0L) +}) diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 861a268f..55b5b51c 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -1121,14 +1121,13 @@ test_that(".checkGwasBlockReach words what it finds", { pip <- c(0.5, 0.3, 0.2) full <- FineMappingRow( .ts_fitted, - list(pip = pip), + list(pip = set_names(pip, .ts_fitted)), data.frame(variant_id = .ts_fitted, pip = pip) ) methods::new( "FineMappingRow", variants = variants(full)[keep], - susieFit = susieFit(full), - fitVariants = .ts_fitted + susieFit = susieFit(full) ) } @@ -1179,33 +1178,62 @@ test_that(".mdFitVariants reads a group's first row, nothing for old rows", { ) }) -test_that(".partsFitIds: the recorded ids, else the fit's, else the row's", { +test_that(".partsFitIds: the row's own ids, else the fit's names", { + # A row holding all of its fit is its fit's variables, read by position. + full <- .ts_fitRow() + expect_equal(pecotmr:::.partsFitIds(full), .ts_fitted) + # A narrowed row's fit names them, wherever it keeps the names. expect_equal(pecotmr:::.partsFitIds(.ts_fitRow(1:2)), .ts_fitted) - unrecorded <- methods::new( + named <- matrix(0, 1L, 3L, dimnames = list(NULL, rev(.ts_fitted))) + fitless <- methods::new( "FineMappingRow", - variants = variants(.ts_fitRow()), + variants = variants(full)[1:2], susieFit = NULL ) - named <- matrix(0, 1L, 3L, dimnames = list(NULL, rev(.ts_fitted))) - expect_equal(pecotmr:::.partsFitIds(unrecorded, named), rev(.ts_fitted)) - expect_equal(pecotmr:::.partsFitIds(unrecorded), .ts_fitted) + expect_equal(pecotmr:::.partsFitIds(fitless, named), rev(.ts_fitted)) + # A narrowed row whose fit names none cannot be placed in it. + unnamed <- methods::new( + "FineMappingRow", + variants = variants(full)[1:2], + susieFit = list(pip = c(0.5, 0.3, 0.2)) + ) + expect_error( + pecotmr:::.partsFitIds(unnamed), + "holds 2 variants but its fit was made with 3" + ) +}) + +test_that(".fitColumnsFor reads a row holding its whole fit by position", { + f <- pecotmr:::.fitColumnsFor + gr <- variants(.ts_fitRow()) + fit <- list(pip = c(0.5, 0.3, 0.2)) + expect_equal(f(gr, fit), 1:3) + # Narrowed: by the fit's names, or not at all without them. + expect_equal(f(gr[2:3], list(pip = set_names(fit$pip, .ts_fitted))), 2:3) + expect_null(f(gr[2:3], fit)) + # A fit of unknown width describes the row as it is. + expect_equal(f(gr[2:3], NULL), 1:2) }) -test_that("a row records fit variants only when it carries a fit", { +test_that(".fitWidth counts the fit's variables, never the null column", { + f <- pecotmr:::.fitWidth + alpha <- matrix(0.25, 1L, 4L) + expect_equal(f(list(pip = c(0.1, 0.2, 0.3), alpha = alpha)), 3L) + expect_equal(f(list(alpha = alpha)), 4L) + expect_equal(f(list(), alpha), 4L) + expect_true(is.na(f(NULL))) + expect_true(is.na(f(list(list(pip = 1))))) +}) + +test_that("a TWAS row records fit variants only when it carries a fit", { w <- c(0.1, 0.2, 0.3) withCv <- TwasWeightsRow(.ts_fitted, w, cvResult = list(r2 = 0.5)) - expect_equal(pecotmr:::.rowFitVariants(withCv), .ts_fitted) - # Weights alone are no fit payload, and topLoci alone no fit. + expect_equal(pecotmr:::.twRowFitVariants(withCv), .ts_fitted) + # Weights alone are no fit payload. expect_equal( - pecotmr:::.rowFitVariants(TwasWeightsRow(.ts_fitted, w)), + pecotmr:::.twRowFitVariants(TwasWeightsRow(.ts_fitted, w)), character(0) ) - fitless <- FineMappingRow( - .ts_fitted, - NULL, - data.frame(variant_id = .ts_fitted, pip = c(0.5, 0.3, 0.2)) - ) - expect_equal(pecotmr:::.rowFitVariants(fitless), character(0)) }) test_that(".fitCoverageChecked warns about a narrowed row and returns it", { @@ -1238,12 +1266,12 @@ test_that(".fitCoverageCheckedRows names at most five narrowed rows", { )) }) -test_that(".fitCoverageCheckedRows is silent without a record or rows", { +test_that(".fitCoverageCheckedRows is silent without a fit or rows", { x <- .ts_narrowedCollection(1L) expect_no_warning(pecotmr:::.fitCoverageCheckedRows(x[0], "f()")) - unrecorded <- x - unrecorded$fitVariants <- NULL - expect_no_warning(pecotmr:::.fitCoverageCheckedRows(unrecorded, "f()")) + fitless <- x + fitless$susieFit <- S4Vectors::SimpleList(list(NULL)) + expect_no_warning(pecotmr:::.fitCoverageCheckedRows(fitless, "f()")) # An optional input left out is nothing to check. expect_no_warning(pecotmr:::.fitCoverageCheckedRows(NULL, "f()")) }) @@ -1273,6 +1301,160 @@ test_that(".narrowedRowLabels labels the narrowed rows and no others", { ) }) +test_that(".narrowedRowLabels finds none where rows record no fit", { + tw <- .ts_weights() + S4Vectors::mcols(tw)$fitVariants <- NULL + expect_identical(pecotmr:::.narrowedRowLabels(tw), character(0)) + fm <- .ts_narrowedCollection(1L) + S4Vectors::mcols(fm)$susieFit <- NULL + expect_identical(pecotmr:::.narrowedRowLabels(fm), character(0)) +}) + +test_that(".partsFitIds: a TWAS row's recorded ids, else its weights' names", { + w <- c(0.1, 0.2, 0.3) + recorded <- TwasWeightsRow(.ts_fitted, w, cvResult = list(r2 = 0.5)) + expect_equal(pecotmr:::.partsFitIds(recorded), .ts_fitted) + plain <- TwasWeightsRow(.ts_fitted, w) + expect_equal(pecotmr:::.partsFitIds(plain), .ts_fitted) + mat <- matrix(0, 1L, 3L, dimnames = list(NULL, rev(.ts_fitted))) + expect_equal(pecotmr:::.partsFitIds(plain, mat), rev(.ts_fitted)) +}) + +# =========================================================================== +# Rows' variants gathered with the columns their fits give back +# =========================================================================== + +# A row on `.ts_fitted` whose table gives the PIPs `tablePip`: the +# constructor stores none when they are the fit's own. +.ts_pipRow <- function(pip, tablePip = pip) { + FineMappingRow( + .ts_fitted, + list(pip = pip), + data.frame(variant_id = .ts_fitted, pip = tablePip) + ) +} + +# A collection of one row per entry of `entry`. +.ts_rows <- function(entry) { + n <- length(entry) + QtlFineMappingResult( + studyName = sprintf("s%d", seq_len(n)), + context = rep("c1", n), + trait = rep("g1", n), + method = rep("susie", n), + entry = entry + ) +} + +test_that("a group of rows gathers their variants with the PIPs restored", { + x <- .ts_rows(list( + .ts_pipRow(c(0.5, 0.3, 0.2)), + .ts_pipRow(c(0.1, 0.2, 0.7)) + )) + expect_false("pip" %in% .fmStoredColumns(x)) + parts <- pecotmr:::.fmrRowParts(x, 1:2) + expect_length(variants(parts), 6L) + expect_equal( + S4Vectors::mcols(variants(parts))$pip, + c(0.5, 0.3, 0.2, 0.1, 0.2, 0.7) + ) +}) + +test_that("rows storing different columns are restored row by row", { + # The second row's table disagrees with its fit, so it keeps its pip. + x <- .ts_rows(list( + .ts_pipRow(c(0.5, 0.3, 0.2)), + .ts_pipRow(c(0.1, 0.2, 0.7), tablePip = c(0.9, 0.05, 0.05)) + )) + gr <- pecotmr:::.fmrGatherVariants(x, 1:2) + expect_equal( + S4Vectors::mcols(gr)$pip, + c(0.5, 0.3, 0.2, 0.9, 0.05, 0.05) + ) +}) + +test_that("rows whose fits give back nothing are gathered as they are", { + gr <- variants(.ts_pipRow(c(0.5, 0.3, 0.2))) + fitless <- methods::new( + "FineMappingRow", + variants = gr, + susieFit = list(alpha = matrix(1 / 3, 1L, 3L)) + ) + x <- .ts_rows(list(fitless, fitless)) + out <- pecotmr:::.fmrGatherVariants(x, 1:2) + expect_length(out, 6L) + expect_null(S4Vectors::mcols(out)$pip) +}) + +test_that("rows recording other derived columns are restored row by row", { + gr <- variants(.ts_pipRow(c(0.5, 0.3, 0.2))) + fit <- list(pip = c(0.5, 0.3, 0.2)) + plain <- methods::new("FineMappingRow", variants = gr, susieFit = fit) + # Recorded credible-set columns its fit, keeping no sets, cannot give. + recorded <- methods::new( + "FineMappingRow", + variants = gr, + susieFit = fit, + derivedColumns = c("cs_95", "method=susie") + ) + mixed <- .ts_rows(list(plain, recorded)) + expect_null(pecotmr:::.fmrRestoreAbsentColumns( + mixed, + 1:2, + pecotmr:::.rtlGatherElements(mixed, 1:2) + )) + expect_equal( + S4Vectors::mcols(pecotmr:::.fmrGatherVariants(mixed, 1:2))$pip, + rep(c(0.5, 0.3, 0.2), 2L) + ) + alike <- .ts_rows(list(recorded, recorded)) + expect_null(pecotmr:::.fmrRestoreAbsentColumns( + alike, + 1:2, + pecotmr:::.rtlGatherElements(alike, 1:2) + )) +}) + +test_that("gathering rows that hold no variants gives none", { + x <- .ts_rows(list(pecotmr:::.fmCvOnlyRow(), pecotmr:::.fmCvOnlyRow())) + expect_length(pecotmr:::.fmrGatherVariants(x, 1:2), 0L) +}) + +test_that("a narrowed row's restored PIPs are found in its fit by name", { + x <- .ts_rows(list(.ts_fitRow(1:2), .ts_fitRow(2:3))) + expect_equal( + S4Vectors::mcols(pecotmr:::.fmrGatherVariants(x, 1:2))$pip, + c(0.5, 0.3, 0.3, 0.2) + ) +}) + +test_that("rows' fit variants come from their ranges or their fits' names", { + x <- .ts_rows(list(.ts_pipRow(c(0.5, 0.3, 0.2)), .ts_fitRow(2:3))) + vars <- pecotmr:::.fmrRowsFitVariants( + x, + 1:2, + pecotmr:::.fmrFitsAt(x, 1:2), + "skip" + ) + expect_identical(vars$n, c(3L, 3L)) + expect_identical( + pecotmr:::.variantTableIds(vars$table), + c(.ts_fitted, .ts_fitted) + ) +}) + +test_that("a narrowed row whose fit names nothing is skipped or refused", { + x <- .ts_narrowedCollection(2L) + fits <- pecotmr:::.fmrFitsAt(x, 1:2) + skipped <- pecotmr:::.fmrRowsFitVariants(x, 1:2, fits, "skip") + expect_identical(skipped$n, c(NA_integer_, NA_integer_)) + expect_identical(pecotmr:::.variantTableSize(skipped$table), 0L) + expect_error( + pecotmr:::.fmrRowsFitVariants(x, 1:2, fits, "error"), + "cannot be placed" + ) +}) + test_that(".fitCoverageCheckedAll names every input's narrowed rows at once", { fm <- .ts_narrowedCollection(2L) cnd <- tryCatch( @@ -1354,13 +1536,17 @@ test_that(".naLikeColumn pads a list column with empty entries of its kind", { expect_null(sl[[1L]]) }) -test_that("binding a collection saved before fitVariants pads the column", { - x <- .ts_narrowedCollection(2L) - old <- x[1L] - old$fitVariants <- NULL - out <- pecotmr:::.rbindCollections(list(old, x[2L])) - expect_s4_class(out$fitVariants, "CharacterList") - expect_equal(unname(lengths(out$fitVariants)), c(0L, 3L)) +test_that("binding a collection saved before derivedColumns pads the column", { + x <- .fmRebuildExample(.fmLoadExample("qtlFineMappingExample")) + recorded <- which(lengths(x$derivedColumns) > 0L)[[1L]] + old <- x[-recorded] + old$derivedColumns <- NULL + out <- pecotmr:::.rbindCollections(list(old, x[recorded])) + expect_s4_class(out$derivedColumns, "CharacterList") + expect_equal( + unname(lengths(out$derivedColumns)), + c(rep(0L, nrow(old)), length(x$derivedColumns[[recorded]])) + ) }) # =========================================================================== @@ -1437,3 +1623,53 @@ test_that("topLoci surfaces the mvsusie lfsr through the projector", { expect_true(is_in("lfsr", names(out))) expect_equal(out$lfsr, c(0.001, 0.02)) }) + +# =========================================================================== +# Column builders and checks +# =========================================================================== + +test_that(".appendProvenanceCol recycles one value and refuses a misfit", { + add <- pecotmr:::.appendProvenanceCol + expect_identical(add(list(), NULL, "dataType", 3L), list()) + expect_identical( + add(list(), "eqtl", "dataType", 2L), + list(dataType = c("eqtl", "eqtl")) + ) + expect_error( + add(list(), c("a", "b"), "dataType", 3L), + "`dataType` must be length 1 or the same length as `study`" + ) +}) + +test_that(".validateRegionColumn names a region column that is not ranges", { + x <- .ts_rows(list(.ts_pipRow(c(0.5, 0.3, 0.2)))) + expect_identical(pecotmr:::.validateRegionColumn(x), character(0)) + md <- S4Vectors::mcols(x) + md$region <- "chr1:1-10" + methods::slot(x, "elementMetadata", check = FALSE) <- md + expect_match(pecotmr:::.validateRegionColumn(x), "^'region' column") +}) + +test_that(".fmrRowLbf reads none from a fit its row cannot be placed in", { + gr <- variants(.ts_pipRow(c(0.5, 0.3, 0.2))) + pip <- c(0.5, 0.3, 0.2) + # A log Bayes factor matrix narrower than the fit's PIPs. + narrow <- methods::new( + "FineMappingRow", + variants = gr, + susieFit = list(pip = pip, lbf_variable = matrix(0, 1L, 2L)) + ) + expect_identical(nrow(pecotmr:::.fmrRowLbf(narrow)), 0L) + none <- methods::new("FineMappingRow", variants = gr, susieFit = list()) + expect_identical(nrow(pecotmr:::.fmrRowLbf(none)), 0L) +}) + +test_that(".ssCombineGenome is NA when no part records a build", { + expect_identical( + pecotmr:::.ssCombineGenome( + list(GenomicRanges::GRanges("chr1:1-2")), + "f" + ), + NA_character_ + ) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 169873e1..2c14181f 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -4789,9 +4789,15 @@ test_that("twasWeightsPipeline refuses a phenotype QC its fits cannot take", { # =========================================================================== # The stub fine-mapping result with its rows narrowed to two of their three -# variants. +# variants. A row is narrowed when it holds fewer variants than its fit has, +# so the stub fits carry the PIPs of all three. .tp_narrowedFineMapping <- function(...) { - endoapply(.tp_makeStubFineMappingResult(...), utils::head, 2L) + x <- .tp_makeStubFineMappingResult(...) + x$susieFit <- S4Vectors::SimpleList(map( + as.list(x$susieFit), + function(fit) c(fit, list(pip = c(0.9, 0.5, 0.1))) + )) + endoapply(x, utils::head, 2L) } test_that("each twasWeightsPipeline method warns about narrowed fits", { diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 1d4fc9e6..0e8f6f05 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -390,24 +390,83 @@ test_that("matchVariants reports sign -1 for an allele swap", { expect_equal(m$sign, -1) }) -test_that("matchVariants handles strand-ambiguous (A/T) swaps with the QC heuristic", { - # A lone A/T swap has no unambiguous strand flip to corroborate a strand - # interpretation, so (mirroring summaryStatsQc) it is treated as a plain - # allele swap and kept with sign -1, not dropped. +test_that("matchVariants judges each strand-ambiguous (A/T) swap on its own", { + # An A/T vs T/A pair is a swap or a strand flip and nothing says which: + # it is dropped by default, whatever else the batch holds ... m <- pecotmr:::matchVariants("chr1:100:A:T", "chr1:100:T:A") - expect_equal(m$idxA, 1L) - expect_equal(m$sign, -1) - - # When the batch contains a genuine unambiguous strand flip ([1]), the - # ambiguous A/T swap ([2]) is dropped as untrustworthy by default ... + expect_length(m$idxA, 0L) a <- c("chr1:100:A:C", "chr2:200:A:T") b <- c("chr1:100:T:G", "chr2:200:T:A") expect_equal(pecotmr:::matchVariants(a, b)$idxA, 1L) - # ... but is kept when ambiguity checking is disabled. + # ... and kept as a swap (sign -1) when ambiguity checking is disabled. + m <- pecotmr:::matchVariants( + "chr1:100:A:T", + "chr1:100:T:A", + removeStrandAmbiguous = FALSE + ) + expect_equal(m$idxA, 1L) + expect_equal(m$sign, -1) expect_equal( sort(pecotmr:::matchVariants(a, b, removeStrandAmbiguous = FALSE)$idxA), c(1L, 2L) ) + # An exact A/T pair is no ambiguity at all. + expect_equal( + pecotmr:::matchVariants("chr1:100:A:T", "chr1:100:A:T")$sign, + 1 + ) +}) + +test_that("matchVariants matches within maxDistance only when alleles agree", { + a <- c("chr1:100:A:G", "chr1:500:C:T") + b <- c("chr1:103:A:G", "chr1:520:C:T", "chr1:101:A:C") + # The same position by default. + expect_length(pecotmr:::matchVariants(a, b)$idxA, 0L) + # Within 5 bp: the A:G copy, not the A:C variant beside it. + m <- pecotmr:::matchVariants(a, b, maxDistance = 5L) + expect_equal(m$idxA, 1L) + expect_equal(m$idxB, 1L) + m <- pecotmr:::matchVariants(a, b, maxDistance = 20L) + expect_equal(m$idxA, c(1L, 2L)) + expect_equal(m$idxB, c(1L, 2L)) + # A swapped copy in the window matches with sign -1; a window never + # crosses chromosomes. + expect_equal( + pecotmr:::matchVariants( + "chr1:100:A:G", + "chr1:102:G:A", + maxDistance = 2L + )$sign, + -1 + ) + expect_length( + pecotmr:::matchVariants( + "chr1:100:A:G", + "chr2:100:A:G", + maxDistance = 10L + )$idxA, + 0L + ) +}) + +test_that("matchVariants takes GRanges of variants", { + ids <- c("chr1:100:A:G", "chr1:200:C:T") + # Ensembl-style seqnames; the first variant stored with its alleles + # swapped. + gr <- GenomicRanges::GRanges( + c("1", "1"), + IRanges::IRanges(c(100L, 200L), width = 1L), + A2 = c("G", "C"), + A1 = c("A", "T") + ) + m <- pecotmr:::matchVariants(gr, ids) + expect_equal(m$idxA, 1:2) + expect_equal(m$sign, c(-1, 1)) + expect_equal(pecotmr:::matchVariants(gr, ids, allowFlip = FALSE)$idxA, 2L) + expect_error( + pecotmr:::matchVariants(GenomicRanges::granges(gr), ids), + "A1 and A2" + ) }) test_that("matchVariants matches non-autosomal variants (chrX, chr23 synonym)", { @@ -1109,3 +1168,11 @@ test_that("normalizeVariantId: argument guards fire", { "convention.*Must be of type 'list'" ) }) + +test_that(".alignIdsToPanel leaves an id that is missing unmatched", { + panel <- c("chr1:100:A:G", "chr1:200:C:T") + expect_identical( + pecotmr:::.alignIdsToPanel(c("chr1:200:C:T", NA), panel), + c(2L, NA) + ) +}) diff --git a/vignettes/coloc-pipeline.Rmd b/vignettes/coloc-pipeline.Rmd index 9c093c1a..f7c5cf68 100644 --- a/vignettes/coloc-pipeline.Rmd +++ b/vignettes/coloc-pipeline.Rmd @@ -162,6 +162,15 @@ with $P_{\text{eQTL}}$ the per-variant QTL prior: p_2 = P_{\text{eQTL}}\,\bigl(1 - \sigma(a_0 + a_1)\bigr), \quad p_{12} = P_{\text{eQTL}}\,\sigma(a_0 + a_1) \] +As in `fastenloc`, $P_{\text{eQTL}}$ and the GWAS prior $P_{\text{GWAS}}$ are +PIP mass per variant: the QTL fits' summed PIPs, and the GWAS PIPs' sum, over +the total number of variants the GWAS tested (`QtlEnrichmentParam(numGwas =)`). +The intercept is the one that keeps the GWAS prior at that rate given the +unshrunk enrichment $\hat a_1$, +$a_0 = \log\{P_{\text{GWAS}} / (1 + P_{\text{eQTL}} e^{\hat a_1} - +P_{\text{eQTL}} - P_{\text{GWAS}})\}$, while the priors above use the shrunk +$a_1$. + `qtlEnrichmentPipeline()` carries all three out as the `colocP1`, `colocP2` and `colocP12` columns, so the table you pass already holds them. Because the enrichment determines the priors, supplying `priors` as well is an error diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd index 8b6b78d5..ed79d7cf 100644 --- a/vignettes/heritability.Rmd +++ b/vignettes/heritability.Rmd @@ -281,14 +281,21 @@ annot <- readAnnotations( The `tier` column decides how each annotation is used: `"baseline"` annotations enter the model and get an enrichment estimate, while -`"candidate"` annotations are scored against the fitted baseline (the sHDL -score test, via `scoreStats()`). - -One structural caveat: a set of baseline annotations that exactly partitions -the variants is rank-deficient by construction, because the model's implicit -all-ones base annotation is then their sum. Real baseline models — the LDSC -baselineLD set, for instance — use overlapping annotations and do not have -this problem. +`"candidate"` annotations are scored against the fitted baseline, one score +test each, via `scoreStats()`. Every estimator calibrates that test by the +spread of its LD blocks' scores, as it does its standard errors, so it stays +valid when the regression weights are only approximately right. Molecular QTL +annotations built by `fineMappingAnnotations()` from fine-mapping results are +candidates by default. + +All four estimators fit the same baseline design. An all-ones base +annotation is added ahead of the baseline annotations unless they already +cover every variant between them, as a partition of the genome does. Without +it the variants no annotation covers would be modelled as carrying no +heritability. Beside the base, an annotation's coefficient is its excess over +the genome-wide rate, which is negative for a depleted annotation. Annotations +may overlap; each one's heritability is taken from the overlap-aware +partition \(A'A\tau\), and only the annotations you supplied are reported. ## Postprocessing external polyfun runs diff --git a/vignettes/xqtl-enrichment.Rmd b/vignettes/xqtl-enrichment.Rmd index 090879d3..84eba03e 100644 --- a/vignettes/xqtl-enrichment.Rmd +++ b/vignettes/xqtl-enrichment.Rmd @@ -105,6 +105,28 @@ supplied to a colocalization analysis. This synthetic single-region example is for illustration only; stable enrichment estimates require many fine-mapped regions. +## The variant total + +As in `fastENLOC`, both priors are PIP mass per variant: the GWAS prior is the +GWAS PIPs' sum, and the QTL prior the QTL fits' summed PIPs, over the total +number of variants the GWAS tested. QTL variants the GWAS PIP vector lacks take +part with GWAS PIP 0. A GWAS fine-mapping collection usually covers only its +fine-mapped blocks, far fewer variants than were tested, so pass that total as +`numGwas`, `fastENLOC`'s `-total_variants`. Without it the pipeline uses the +number of distinct variants in the two inputs and warns, as it did above; +that overstates both priors unless the GWAS PIPs are genome-wide. + +```{r enrichment-num-gwas, eval = FALSE} +qtlEnrichmentPipeline( + gwasFineMappingResult = gwasFmr, + qtlFineMappingResult = qtlFmr, + # e.g. the number of variants in the GWAS summary statistics + qtlEnrichmentParam = QtlEnrichmentParam(numGwas = 12e6), + BPPARAM = BiocParallel::MulticoreParam(8), + seed = 1 +) +``` + ## Session information Here are some details about the computing environment, including the versions