diff --git a/NAMESPACE b/NAMESPACE index 95e2ca3a..09b8093d 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -42,6 +42,8 @@ export(bayesCWeights) export(bayesLWeights) export(bayesNWeights) export(bayesRWeights) +export(buildLdEigen) +export(buildLdScore) export(buildMrmashPriorMatrices) export(buildTopLoci) export(calculateFeatureScores) @@ -84,7 +86,6 @@ export(filterInvalidSummaryStat) export(filterMixtureComponents) export(filterRelatedness) export(filterVariantsByLdReference) -export(findOverlappingRegions) export(fineMappingPipeline) export(fineMappingRow) export(finemapCtwasRegions) @@ -177,14 +178,13 @@ export(getSnpIdx) export(getStandardized) export(getStudy) export(getSumStats) -export(getSumstatDf) +export(getSumStatsDf) export(getSusieAlpha) export(getSusieFit) export(getSusieResult) export(getTauBlocks) export(getTopLoci) export(getTraitName) -export(getTraitNames) export(getTraitPosition) export(getTraitRun) export(getTraitRuns) @@ -210,15 +210,12 @@ export(lassosumRss) export(lassosumRssWeights) export(lbfToAlpha) export(ldClumpByScore) -export(ldLoader) export(ldMismatchQc) export(ldPruneByCorrelation) export(learnTwasWeights) export(loadGenotypeRegion) export(loadGwasSumStatsFromManifest) -export(loadLdBlock) export(loadLdMatrix) -export(loadLdSketch) export(loadMultiStudyQtlDatasetFromManifest) export(loadQtlDatasetFromManifest) export(loadQtlSumStatsFromManifest) @@ -240,7 +237,7 @@ export(mergeSusieCs) export(mergeVariantInfo) export(metaAnalysisPerCondition) export(metaSldscRandom) -export(mrAshRssWeights) +export(mrashRssWeights) export(mrashWeights) export(mrmashRssWeights) export(mrmashWeights) @@ -271,7 +268,6 @@ export(readSldscAnnot) export(readSldscFrq) export(readSldscTrait) export(regionToDf) -export(regionsOverlap) export(resolveWeights) export(sanitizeMashData) export(scadRssWeights) @@ -300,9 +296,8 @@ export(twasWeightsPipeline) export(twasWeightsRow) export(twasZ) export(updateMashModelCov) -export(variantIdToDf) export(waldTestPval) -export(writeSumstatsVcf) +export(writeSumStatsVcf) exportClasses(AnnotationMatrix) exportClasses(ColocBoostResult) exportClasses(ColocResult) @@ -416,13 +411,12 @@ exportMethods(getSnpIdx) exportMethods(getStandardized) exportMethods(getStudy) exportMethods(getSumStats) -exportMethods(getSumstatDf) +exportMethods(getSumStatsDf) exportMethods(getSusieAlpha) exportMethods(getSusieFit) exportMethods(getTauBlocks) exportMethods(getTopLoci) exportMethods(getTraitName) -exportMethods(getTraitNames) exportMethods(getTraitPosition) exportMethods(getTraitRun) exportMethods(getTraitRuns) @@ -449,7 +443,7 @@ exportMethods(show) exportMethods(subsetChr) exportMethods(subsetRegion) exportMethods(twasWeightsPipeline) -exportMethods(writeSumstatsVcf) +exportMethods(writeSumStatsVcf) importClassesFrom(GenomicRanges,GRanges) importClassesFrom(MultiAssayExperiment,MultiAssayExperiment) importClassesFrom(S4Vectors,DataFrame) diff --git a/R/AllClasses.R b/R/AllClasses.R index 6b553525..80c6aedb 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -85,7 +85,7 @@ setClassUnion("LdMixtureWeights", c("numeric", "NULL")) # # getZ / getN / getMaf / nSnps are # defined once on SumStatsBase (they only delegate to getSumStats); subsetChr / -# getVarY / getSumStats / getSumstatDf stay on the concrete subclass because +# getVarY / getSumStats / getSumStatsDf stay on the concrete subclass because # they rely on the tuple shape (3-tuple QtlSumStats, 1-tuple GwasSumStats). # ============================================================================= diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 45e9db69..f69815b4 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -23,11 +23,30 @@ NULL # ============================================================================= #' @title Estimate SNP Heritability -#' @description Estimate SNP heritability from GWAS summary statistics using one -#' of three methods: LDER, g-LDSC, or HDL/sHDL. +#' @description Estimate SNP heritability from GWAS summary statistics using +#' one of four methods: S-LDSC, g-LDSC, LDER, or HDL/sHDL. Supplying +#' \code{annotations} makes any of them stratified. #' @param sumstats A \code{GwasSumStats} object. -#' @param ldRef An \code{LdStatistic} object (method-appropriate subclass). -#' @param method Character, one of "lder", "gldsc", "hdl". +#' @param ldRef An \code{LdStatistic} object (method-appropriate subclass): +#' an \code{\link{LdScore}} for \code{"sldsc"} / \code{"gldsc"}, an +#' \code{\link{LdEigen}} for \code{"lder"} / \code{"hdl"}. Build either +#' from loaded LD with \code{\link{buildLdScore}} / +#' \code{\link{buildLdEigen}}. +#' @param method Character, one of \code{"lder"} (the default), +#' \code{"sldsc"}, \code{"gldsc"} or \code{"hdl"}: +#' \describe{ +#' \item{\code{"sldsc"}}{Stratified LD score regression (Finucane et al. +#' 2015): weighted least squares of \eqn{\chi^2} on LD scores. Needs +#' only per-variant scores when unstratified, so it is the cheapest of +#' the four and the only one that runs on a scores-only +#' \code{LdScore}.} +#' \item{\code{"gldsc"}}{Generalized LD score regression (Xiong et al. +#' 2024): GLS using the full per-block LD matrices.} +#' \item{\code{"lder"}}{LD eigenvalue regression (Song et al. 2022).} +#' \item{\code{"hdl"}}{High-definition likelihood (Ning et al. 2020), +#' stratified as sHDL. Models reference-panel noise explicitly, so it +#' shrinks hard when \code{nRef} is small.} +#' } #' @param annotations An \code{AnnotationMatrix} object, or NULL for #' unstratified estimation. #' @param local Logical, whether to compute per-block local estimates. @@ -36,17 +55,23 @@ NULL #' this study; \code{NULL} matches all studies. #' @return An \code{H2Estimate} object. #' @examples -#' data(ldEigenExample) -#' gr <- GenomicRanges::GRanges("chr1", -#' IRanges::IRanges(seq(50, by = 100, length.out = 20), width = 1)) -#' S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:20), -#' A1 = "A", A2 = "G", Z = rnorm(20), N = 10000L) +#' data(ldScoreExample) +#' # The estimators index the z-scores by the reference's own variant order, +#' # so build the sumstats from the reference rather than alongside it. +#' gr <- as(ldScoreExample, "GRanges") +#' set.seed(1) +#' S4Vectors::mcols(gr) <- S4Vectors::DataFrame( +#' SNP = names(ldScoreExample), +#' A1 = S4Vectors::mcols(ldScoreExample)$A1, +#' A2 = S4Vectors::mcols(ldScoreExample)$A2, +#' Z = rnorm(length(ldScoreExample)), +#' N = 100000L) #' panel <- readGenotypes( #' system.file("extdata", "toy_ref.bed", package = "pecotmr") #' ) #' ss <- GwasSumStats(study = "trait1", entry = list(gr), -#' genome = "hg19", ldSketch = panel) -#' estimateH2(ss, ldEigenExample, method = "lder") +#' genome = getGenome(ldScoreExample), ldSketch = panel) +#' estimateH2(ss, ldScoreExample, method = "sldsc") #' @export setGeneric( "estimateH2", @@ -561,9 +586,9 @@ setGeneric("getSumStats", function(x, ...) standardGeneric("getSumStats")) #' @return A \code{data.frame}. #' @examples #' data(qtlSumStatsExample) -#' getSumstatDf(qtlSumStatsExample) +#' getSumStatsDf(qtlSumStatsExample) #' @export -setGeneric("getSumstatDf", function(x, ...) standardGeneric("getSumstatDf")) +setGeneric("getSumStatsDf", function(x, ...) standardGeneric("getSumStatsDf")) #' @title Get the Embedded QtlDataset List #' @description Return the named list of \code{QtlDataset} objects carried by a @@ -1203,8 +1228,10 @@ setGeneric("getDataType", function(x, ...) standardGeneric("getDataType")) #' Write summary statistics or fine-mapping results to VCF/BCF #' #' Creates a VCF object from GWAS summary statistics or fine-mapping results and -#' writes it to disk. Supports bgzipped VCF (.vcf.gz/.vcf.bgz) and BCF (.bcf) -#' output formats via VariantAnnotation and Rsamtools. +#' writes it to disk via VariantAnnotation and Rsamtools. Supports bgzipped +#' VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) additionally needs a working +#' \code{Rsamtools::asBcf()}, which recent Rsamtools releases disable, so +#' prefer .vcf.bgz. #' #' @param x Input data: a \code{GwasSumStats} object, a \code{FineMappingResult} #' object, or a data.frame with columns \code{chrom}, \code{pos}, \code{ref}, @@ -1230,11 +1257,11 @@ setGeneric("getDataType", function(x, ...) standardGeneric("getDataType")) #' @return Invisible path to the written file. #' @examples #' data(gwasSumStatsS4Example) -#' writeSumstatsVcf( +#' writeSumStatsVcf( #' gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) #' @export -setGeneric("writeSumstatsVcf", function(x, outputPath, sampleName = NULL, ...) { - standardGeneric("writeSumstatsVcf") +setGeneric("writeSumStatsVcf", function(x, outputPath, sampleName = NULL, ...) { + standardGeneric("writeSumStatsVcf") }) # ============================================================================= @@ -1262,7 +1289,8 @@ setGeneric("getContexts", function(x) standardGeneric("getContexts")) #' @title Get Unique Trait Names #' @description Return the unique trait identifiers carried by a collection -#' class (e.g., \code{QtlSumStats}). +#' class (e.g., \code{QtlSumStats}), or the trait names of an +#' \code{\link{SldscData}}. #' @param x The object. #' @return Character vector of unique trait names. #' @examples @@ -1893,38 +1921,6 @@ setGeneric("getFrqData", function(x) standardGeneric("getFrqData")) #' @export setGeneric("getTraitRuns", function(x) standardGeneric("getTraitRuns")) -#' @title Get the trait names from an SldscData -#' @param x An \code{\link{SldscData}} object. -#' @return A character vector of trait names. -#' @rdname getTraitNames -#' @examples -#' mkRun <- function(cats) { -#' n <- length(cats) -#' list(categories = cats, tau = setNames(rep(1e-7, n), cats), -#' tauSe = setNames(rep(3e-8, n), cats), -#' enrichment = setNames(rep(2, n), cats), -#' enrichmentSe = setNames(rep(0.4, n), cats), -#' enrichmentP = setNames(rep(0.01, n), cats), -#' propH2 = setNames(rep(0.2, n), cats), -#' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), -#' nBlocks = 10L) -#' } -#' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), -#' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) -#' frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), -#' MAF = rep(0.2, 6)) -#' mkTrait <- function() { -#' list(single = list(mkRun(c("annot_A_0", "baselineLD_0")), -#' mkRun(c("annot_B_0", "baselineLD_0"))), -#' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) -#' } -#' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' getTraitNames(sd) -#' @export -setGeneric("getTraitNames", function(x) standardGeneric("getTraitNames")) - #' @title Get the annotation column names from an SldscData #' @param x An \code{\link{SldscData}} object. #' @return A character vector of annotation column names. diff --git a/R/GenotypeHandle.R b/R/GenotypeHandle.R index 59ef8689..8a5bc7c4 100644 --- a/R/GenotypeHandle.R +++ b/R/GenotypeHandle.R @@ -310,7 +310,7 @@ GenotypeHandle <- function( msg <- glue( "GenotypeHandle: the LD-meta row for region {regionStr} points ", "at a pre-computed correlation matrix ({ldPath}). Use ", - "loadLdMatrix() / loadLdSketch() for .cor.xz inputs; ", + "loadLdMatrix() for .cor.xz inputs; ", "GenotypeHandle accepts only genotype payloads (VCF/GDS/PLINK)." ) abort(msg) diff --git a/R/LdEigen.R b/R/LdEigen.R index e7598adf..5b696c68 100644 --- a/R/LdEigen.R +++ b/R/LdEigen.R @@ -110,6 +110,103 @@ LdEigen <- function( obj } +#' @title Build an LdEigen from loaded LD +#' @description Eigendecompose already-loaded LD, block by block, into the +#' \code{LdEigen} that \code{\link{estimateH2}} consumes for +#' \code{method = "lder"} and \code{method = "hdl"}. This is the supported +#' route from an LD reference to an h2 input: \code{\link{LdEigen}} itself +#' is the low-level constructor and expects the decompositions to have been +#' computed already. +#' +#' No file I/O happens here. Read the LD first with +#' \code{\link{loadLdMatrix}} -- passing a vector of regions returns one +#' \code{LdData} per block -- then pass the result in. +#' @param ldBlockData An \code{\link{LdData}}, or a list of them, covering +#' the reference variants. An \code{LdData} whose correlation is a list of +#' per-block matrices contributes one LD block per matrix; one whose +#' correlation is a single matrix contributes one block. Blocks are kept in +#' the order given, and that order defines the variant order of the result. +#' +#' Block structure matters downstream: \code{\link{estimateH2}} takes its +#' standard error from a delete-one-block jackknife, so it requires at +#' least two blocks and wants many more. Loading a whole region as one +#' dense matrix yields a single block. +#' @param nRef Integer, the LD reference panel sample size. Defaults to the +#' size recorded by the supplied \code{LdData}; required when they record +#' none, and an error when they disagree. +#' @param inSample Logical, whether the reference is the GWAS cohort itself. +#' Selects LDER's weighting and HDL's finite-reference correction. +#' @param genome Character, genome build. Defaults to the build recorded by +#' the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves +#' unset. +#' @param eigenvalueTruncation Numeric in (0, 1]; the proportion of each +#' block's eigenvalue mass to retain. \code{1} (the default) keeps every +#' component; HDL conventionally uses \code{0.9}. +#' @return An \code{LdEigen} over every variant in \code{ldBlockData}. +#' @seealso \code{\link{buildLdScore}} for the g-LDSC input, +#' \code{\link{estimateH2}}, \code{\link{loadLdMatrix}} +#' @examples +#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", +#' package = "pecotmr") +#' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") +#' ldEigen <- buildLdEigen(ld, genome = "hg38") +#' ldEigen +#' length(getEigenList(ldEigen)) +#' @export +buildLdEigen <- function( + ldBlockData, + nRef = NULL, + inSample = FALSE, + genome = NA_character_, + eigenvalueTruncation = 1 +) { + prep <- .ldRefPrepare(ldBlockData, nRef, genome) + eigenList <- map2( + prep$blocks, + prep$snpIdx, + .ldEigenOneBlock, + truncation = eigenvalueTruncation + ) + LdEigen( + snpInfo = prep$snpInfo, + eigenList = eigenList, + ldBlocks = prep$ldBlocks, + nRef = prep$nRef, + inSample = inSample, + genome = prep$genome, + eigenvalueTruncation = eigenvalueTruncation + ) +} + +# One block's decomposition, truncated to the leading components carrying +# `truncation` of its eigenvalue mass. +# @noRd +.ldEigenOneBlock <- function(block, snpIdx, truncation) { + e <- eigen(block$R, symmetric = TRUE) + keep <- .ldEigenKeep(e$values, truncation) + list( + values = e$values[keep], + vectors = e$vectors[, keep, drop = FALSE], + snpIdx = as.integer(snpIdx) + ) +} + +# Rounding can leave a near-singular block with slightly negative trailing +# eigenvalues, so the cumulative mass is taken over the clamped values -- +# otherwise the running total can dip and pick the wrong cut point. +# @noRd +.ldEigenKeep <- function(values, truncation) { + if (truncation >= 1) { + return(seq_along(values)) + } + positive <- pmax(values, 0) + total <- sum(positive) + if (total <= 0) { + return(seq_along(values)) + } + seq_len(which(cumsum(positive) / total >= truncation)[[1L]]) +} + #' @describeIn LdEigen-class Refused. Subsetting would narrow the variants #' while \code{eigenList} -- a slot, because it is per block rather than #' per variant -- stayed as it was, leaving decompositions that describe diff --git a/R/LdScore.R b/R/LdScore.R index 8f9b7afe..273a3622 100644 --- a/R/LdScore.R +++ b/R/LdScore.R @@ -106,6 +106,113 @@ LdScore <- function( obj } +#' @title Build an LdScore from loaded LD +#' @description Compute per-variant LD scores from already-loaded LD, block by +#' block, into the \code{LdScore} that \code{\link{estimateH2}} consumes +#' for \code{method = "gldsc"}. This is the supported route from an LD +#' reference to an h2 input: \code{\link{LdScore}} itself is the low-level +#' constructor and expects the scores to have been computed already. +#' +#' The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, the same +#' quantity \code{\link{computeLdScores}} reconstructs from an +#' \code{\link{LdEigen}}, so the two agree on a shared reference. +#' +#' No file I/O happens here. Read the LD first with +#' \code{\link{loadLdMatrix}} -- passing a vector of regions returns one +#' \code{LdData} per block -- then pass the result in. +#' @param ldBlockData An \code{\link{LdData}}, or a list of them, covering +#' the reference variants. An \code{LdData} whose correlation is a list of +#' per-block matrices contributes one LD block per matrix; one whose +#' correlation is a single matrix contributes one block. Blocks are kept in +#' the order given, and that order defines the variant order of the result. +#' +#' Block structure matters downstream: \code{\link{estimateH2}} takes its +#' standard error from a delete-one-block jackknife, so it requires at +#' least two blocks and wants many more. Loading a whole region as one +#' dense matrix yields a single block. +#' @param nRef Integer, the LD reference panel sample size. Defaults to the +#' size recorded by the supplied \code{LdData}; required when they record +#' none, and an error when they disagree. +#' @param inSample Logical, whether the reference is the GWAS cohort itself. +#' @param genome Character, genome build. Defaults to the build recorded by +#' the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves +#' unset. +#' @param ldScoreWeights Optional numeric regression weights, one per variant. +#' Defaults to the conventional \eqn{1/\max(\ell_j, 1)}. +#' @param keepLdMatrices Logical. Keep each block's LD matrix on the result. +#' \code{TRUE} (the default) is required for \code{method = "gldsc"}, +#' which forms its FGLS residual covariance from them and errors without +#' them. \code{FALSE} drops them, leaving a scores-only object. +#' @return An \code{LdScore} over every variant in \code{ldBlockData}. +#' @seealso \code{\link{buildLdEigen}} for the LDER / HDL input, +#' \code{\link{estimateH2}}, \code{\link{computeLdScores}} +#' @examples +#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", +#' package = "pecotmr") +#' ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") +#' ldScore <- buildLdScore(ld, genome = "hg38") +#' ldScore +#' head(getLdScores(ldScore)) +#' @export +buildLdScore <- function( + ldBlockData, + nRef = NULL, + inSample = FALSE, + genome = NA_character_, + ldScoreWeights = NULL, + keepLdMatrices = TRUE +) { + prep <- .ldRefPrepare(ldBlockData, nRef, genome) + l2 <- .ldScoreVector(prep$blocks, prep$snpIdx, nrow(prep$snpInfo)) + ldMatrixList <- if (isTRUE(keepLdMatrices)) { + map2(prep$blocks, prep$snpIdx, .ldScoreKeepMatrix) + } else { + list() + } + LdScore( + snpInfo = prep$snpInfo, + ldScores = matrix(l2, ncol = 1, dimnames = list(NULL, "base_l2")), + ldScoreWeights = .ldScoreResolveWeights(ldScoreWeights, l2), + ldBlocks = prep$ldBlocks, + nRef = prep$nRef, + inSample = inSample, + genome = prep$genome, + ldMatrixList = ldMatrixList + ) +} + +# Per-variant sum of r^2 within the variant's own block, scattered back into +# reference order. +# @noRd +.ldScoreVector <- function(blocks, snpIdx, nVariants) { + l2 <- numeric(nVariants) + for (b in seq_along(blocks)) { + l2[snpIdx[[b]]] <- rowSums(blocks[[b]]$R^2) + } + l2 +} + +# @noRd +.ldScoreKeepMatrix <- function(block, snpIdx) { + list(R = block$R, snpIdx = as.integer(snpIdx)) +} + +# The conventional LDSC heteroskedasticity weight, with the score floored at +# 1 so a variant in near-perfect linkage equilibrium cannot dominate. +# @noRd +.ldScoreResolveWeights <- function(ldScoreWeights, l2) { + if (is.null(ldScoreWeights)) { + return(1 / pmax(l2, 1)) + } + if (length(ldScoreWeights) != length(l2)) { + abort(glue( + "`ldScoreWeights` has {length(ldScoreWeights)} value(s) for ", + "{length(l2)} variant(s)." + )) + } + as.numeric(ldScoreWeights) +} + #' @rdname show-methods #' @export setMethod("show", "LdScore", function(object) { diff --git a/R/LdStatistic.R b/R/LdStatistic.R index e2d92a2c..60d82776 100644 --- a/R/LdStatistic.R +++ b/R/LdStatistic.R @@ -80,6 +80,275 @@ setClass( gr } +# ============================================================================= +# Building an LD statistic from already-loaded LD +# ----------------------------------------------------------------------------- +# buildLdEigen() and buildLdScore() both start from LD that has already been +# read -- one or more LdData, as loadLdMatrix() returns them -- +# and differ only in what they compute per block. Everything before that +# (splitting into blocks, assembling the variant table, resolving nRef and the +# genome build) is shared, so it lives here next to .ldStatRanges(). +# ============================================================================= + +# Shared front half of buildLdEigen()/buildLdScore(): validate the input, +# split it into blocks, and resolve what the LdStatistic base needs. +# @noRd +.ldRefPrepare <- function(ldBlockData, nRef, genome) { + dataList <- .ldRefAsDataList(ldBlockData) + blocks <- list_flatten(map(dataList, .ldRefBlocksOf)) + resolvedGenome <- .ldRefResolveGenome(dataList, genome) + list( + blocks = blocks, + snpInfo = .ldRefSnpInfo(blocks), + snpIdx = .ldRefSnpIdx(blocks), + ldBlocks = .ldRefBlockRanges(blocks, resolvedGenome), + nRef = .ldRefResolveNRef(dataList, nRef), + genome = resolvedGenome + ) +} + +# Accept a single LdData as well as a list of them. +# @noRd +.ldRefAsDataList <- function(ldBlockData) { + if (is(ldBlockData, "LdData")) { + return(list(ldBlockData)) + } + if (!is.list(ldBlockData) || length(ldBlockData) == 0L) { + abort(glue( + "`ldBlockData` must be an LdData or a non-empty list of them ", + "(got {class(ldBlockData)[[1L]]})." + )) + } + bad <- which(!map_lgl(ldBlockData, is, class2 = "LdData")) + if (length(bad) > 0L) { + abort(glue( + "`ldBlockData` element(s) {str_flatten(bad, ', ')} are not ", + "LdData objects." + )) + } + ldBlockData +} + +# The per-block LD matrices of one LdData, each paired with the variants it +# describes. An LdData holds either a single matrix (one block) or a list of +# them (block-diagonal LD across a multi-block region). +# @noRd +.ldRefBlocksOf <- function(x) { + R <- getCorrelation(x) + gr <- getVariantInfo(x) + if (!is.list(R)) { + return(list(.ldRefOneBlock(R, gr))) + } + idx <- .ldRefBlockIndices(x, R, length(gr)) + map2(R, idx, .ldRefBlockFromIdx, gr = gr) +} + +# @noRd +.ldRefBlockFromIdx <- function(R, idx, gr) { + .ldRefOneBlock(R, gr[idx]) +} + +# @noRd +.ldRefOneBlock <- function(R, gr) { + R <- as.matrix(R) + if (nrow(R) != length(gr)) { + abort(glue( + "an LD block's correlation matrix is {nrow(R)}x{ncol(R)} but ", + "covers {length(gr)} variant(s)." + )) + } + list(R = R, gr = gr) +} + +# Which variants each block matrix covers. blockMetadata's startIdx/endIdx is +# authoritative when it lines up with the matrices; otherwise the blocks are +# taken in order, each covering as many variants as its matrix has rows. +# @noRd +.ldRefBlockIndices <- function(x, R, nVariants) { + sizes <- map_int(R, nrow) + if (sum(sizes) != nVariants) { + abort(glue( + "the LD block matrices cover {sum(sizes)} variant(s) but the ", + "LdData carries {nVariants}." + )) + } + md <- getBlockMetadata(x) + hasIdx <- is.data.frame(md) && + all(is_in(c("startIdx", "endIdx"), names(md))) && + nrow(md) == length(R) + if (hasIdx) { + return(map2(as.integer(md$startIdx), as.integer(md$endIdx), seq.int)) + } + ends <- cumsum(sizes) + map2(as.integer(ends - sizes + 1L), as.integer(ends), seq.int) +} + +# Global (concatenated) variant positions of each block. +# @noRd +.ldRefSnpIdx <- function(blocks) { + sizes <- map_int(blocks, .ldRefBlockSize) + ends <- cumsum(sizes) + map2(as.integer(ends - sizes + 1L), as.integer(ends), seq.int) +} + +# @noRd +.ldRefBlockSize <- function(block) length(block$gr) + +# The variant table .ldStatRanges() expects, stacked over the blocks in +# order. An LdData names its variants `variant_id`, and reports frequency as +# allele_freq rather than MAF. +# @noRd +.ldRefSnpInfo <- function(blocks) { + bind_rows(map(blocks, .ldRefSnpInfoOne)) +} + +# @noRd +.ldRefSnpInfoOne <- function(block) { + gr <- block$gr + md <- S4Vectors::mcols(gr, use.names = FALSE) + info <- tibble( + SNP = .ldRefVariantIds(gr, md), + CHR = as.character(seqnames(gr)), + BP = as.integer(start(gr)), + A1 = .ldRefAllele(md, "A1"), + A2 = .ldRefAllele(md, "A2") + ) + maf <- .ldRefMaf(md) + if (is.null(maf)) info else mutate(info, MAF = maf) +} + +# @noRd +.ldRefVariantIds <- function(gr, md) { + if (is_in("variant_id", colnames(md))) { + return(as.character(md$variant_id)) + } + if (is_in("SNP", colnames(md))) { + return(as.character(md$SNP)) + } + if (!is.null(names(gr))) { + return(as.character(names(gr))) + } + str_c(as.character(seqnames(gr)), ":", start(gr)) +} + +# @noRd +.ldRefAllele <- function(md, which) { + if (!is_in(which, colnames(md))) { + abort(glue( + "the LD reference's variants carry no `{which}` column; an ", + "LdStatistic needs both alleles." + )) + } + as.character(md[[which]]) +} + +# @noRd +.ldRefMaf <- function(md) { + if (is_in("MAF", colnames(md))) { + return(as.numeric(md$MAF)) + } + if (is_in("allele_freq", colnames(md))) { + af <- as.numeric(md$allele_freq) + return(pmin(af, 1 - af)) + } + NULL +} + +# One range per block, spanning the variants it covers. These are the blocks +# the jackknife leaves out one at a time, so they must line up with +# eigenList / ldMatrixList element for element. +# @noRd +.ldRefBlockRanges <- function(blocks, genome) { + gr <- GRanges( + seqnames = map_chr(blocks, .ldRefBlockChrom), + ranges = IRanges::IRanges( + start = map_int(blocks, .ldRefBlockStart), + end = map_int(blocks, .ldRefBlockEnd) + ) + ) + if (.ldRefNamedGenome(genome)) { + GenomeInfoDb::genome(gr) <- genome + } + gr +} + +# An LD block is within-chromosome by construction, and .ldRefBlockRanges() +# collapses each to a single range, so a block spanning chromosomes would +# silently get a range covering everything between them. +# @noRd +.ldRefBlockChrom <- function(block) { + chrom <- unique(withChrPrefix(as.character(seqnames(block$gr)))) + if (length(chrom) != 1L) { + abort(glue( + "an LD block spans {length(chrom)} chromosomes ", + "({str_flatten(chrom, ', ')}); each block must lie on one." + )) + } + chrom +} + +# @noRd +.ldRefBlockStart <- function(block) as.integer(min(start(block$gr))) + +# @noRd +.ldRefBlockEnd <- function(block) as.integer(max(start(block$gr))) + +# @noRd +.ldRefNamedGenome <- function(genome) { + !is.null(genome) && + length(genome) == 1L && + !is.na(genome) && + nzchar(genome) +} + +# nRef comes from the LdData unless the caller names one. Differing panel +# sizes are an error rather than a silent pick: nRef drives HDL's +# finite-reference correction, so the wrong one shifts h2. +# @noRd +.ldRefResolveNRef <- function(dataList, nRef) { + if (!is.null(nRef)) { + return(as.integer(nRef)) + } + found <- unique(map_int(dataList, .ldRefNRefOf)) + found <- found[!is.na(found)] + if (length(found) == 0L) { + abort(glue( + "`nRef` is required: none of the supplied LdData records a ", + "reference panel sample size." + )) + } + if (length(found) > 1L) { + abort(glue( + "the supplied LdData record differing reference panel sizes ", + "({str_flatten(found, ', ')}); pass `nRef` to choose one." + )) + } + found[[1L]] +} + +# @noRd +.ldRefNRefOf <- function(x) { + n <- getNRef(x) + if (length(n) == 0L) NA_integer_ else as.integer(n[[1L]]) +} + +# @noRd +.ldRefResolveGenome <- function(dataList, genome) { + if (.ldRefNamedGenome(genome)) { + return(genome) + } + found <- unique(map_chr(dataList, .ldRefGenomeOf)) + found <- found[!is.na(found)] + if (length(found) == 1L) found[[1L]] else NA_character_ +} + +# @noRd +.ldRefGenomeOf <- function(x) { + g <- unique(GenomeInfoDb::genome(as(x, "GRanges"))) + g <- g[!is.na(g)] + if (length(g) == 1L) g[[1L]] else NA_character_ +} + #' @rdname getNRef #' @export setMethod("getNRef", "LdStatistic", function(x) x@nRef) diff --git a/R/QtlDataset.R b/R/QtlDataset.R index cda5972a..7c7bf060 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -1072,12 +1072,11 @@ setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { # list(dosage, maf, af). # @noRd .qtlVariantFilters <- function(dosage, x) { + # No zero-variant guard: the only caller returns early when snpIdx is + # empty, and extraction preserves the column count (.restoreRequestedOrder + # aborts on a mismatch). The body is 0-column safe regardless -- colSums + # gives numeric(0) and the mask logical(0), yielding the same empty result. nSamp <- nrow(dosage) - if (ncol(dosage) == 0L) { - # nocov start (unreachable: zero-variant paths return early above) - return(list(dosage = dosage, maf = numeric(0), af = numeric(0))) - # nocov end - } nObs <- colSums(!is.na(dosage)) sumD <- colSums(dosage, na.rm = TRUE) p <- if_else(nObs > 0L, sumD / (2 * nObs), NA_real_) diff --git a/R/RangedTupleList.R b/R/RangedTupleList.R index 13db03e2..8024da1b 100644 --- a/R/RangedTupleList.R +++ b/R/RangedTupleList.R @@ -44,6 +44,10 @@ NULL #' @param drop Passed through to the inherited method. #' @param ... Additional arguments passed on. #' @param FUN A function applied to each element, returning a \code{GRanges}. +#' @param objects Further collections to append, as \code{c()} and +#' \code{append()} pass them. +#' @param use.names,ignore.mcols,check Unused; present for generic +#' compatibility. #' @return \code{nrow()} and \code{ncol()} integers; \code{colnames()} a #' character vector; \code{$} a metadata column; \code{$<-}, \code{[} and #' \code{endoapply()} a collection of the same class. @@ -228,8 +232,10 @@ setMethod("nrow", "RangedTupleList", function(x) length(x)) #' @rdname RangedTupleList-methods #' @export setMethod("ncol", "RangedTupleList", function(x) { - md <- mcols(x, use.names = FALSE) - if (is.null(md)) 0L else ncol(md) + # No is.null() arm: `elementMetadata` is a typed DataFrame slot, so a + # collection with no metadata carries a zero-COLUMN DataFrame rather than + # NULL, and ncol() already answers 0 for it. + ncol(mcols(x, use.names = FALSE)) }) #' @rdname RangedTupleList-methods @@ -239,29 +245,22 @@ setMethod("colnames", "RangedTupleList", function(x, do.NULL = TRUE, prefix) { # Completes the nrow / ncol / `$` set. Without it `colnames(x)` returns # NULL rather than erroring, so code that asks a collection for its column # names gets a silent wrong answer instead of a signal. - md <- mcols(x, use.names = FALSE) - if (is.null(md)) NULL else colnames(md) + colnames(mcols(x, use.names = FALSE)) }) #' @rdname RangedTupleList-methods #' @export setMethod("$", "RangedTupleList", function(x, name) { - md <- mcols(x, use.names = FALSE) - if (is.null(md)) { - return(NULL) - } - md[[name]] + # A zero-column DataFrame answers NULL for any name, which is the same + # thing the removed is.null() arm returned. + mcols(x, use.names = FALSE)[[name]] }) #' @rdname RangedTupleList-methods #' @export setMethod("$<-", "RangedTupleList", function(x, name, value) { md <- mcols(x, use.names = FALSE) - if (is.null(md)) { - md <- S4Vectors::DataFrame(set_names(list(value), name)) - } else { - md[[name]] <- value - } + md[[name]] <- value mcols(x) <- md x }) @@ -752,10 +751,9 @@ nestTupleRanges <- function(flat, template) { # The identity columns to group by: the atomic mcols the flattener broadcasts. # @noRd .rtlTupleKeyCols <- function(x) { + # No is.null() arm: see ncol() above -- mcols() answers a zero-column + # DataFrame, and names() of one is already character(0). md <- mcols(x, use.names = FALSE) - if (is.null(md)) { - return(character(0)) - } names(md)[map_lgl(as.list(md), is.atomic)] } diff --git a/R/SldscData.R b/R/SldscData.R index faf4d93a..65a87abf 100644 --- a/R/SldscData.R +++ b/R/SldscData.R @@ -174,9 +174,9 @@ setMethod("getFrqData", "SldscData", function(x) x@frq) #' @export setMethod("getTraitRuns", "SldscData", function(x) x@traits) -#' @rdname getTraitNames +#' @rdname getTraits #' @export -setMethod("getTraitNames", "SldscData", function(x) names(x@traits)) +setMethod("getTraits", "SldscData", function(x) names(x@traits)) #' @rdname getAnnotCols #' @export diff --git a/R/causalInferencePipeline.R b/R/causalInferencePipeline.R index 1973e60a..5cbb02af 100644 --- a/R/causalInferencePipeline.R +++ b/R/causalInferencePipeline.R @@ -349,7 +349,11 @@ causalInferencePipeline <- function( # @noRd .cipScoreGwasPair <- function(gi, tuple, weightsInfo, fmrEntry, p) { gStudy <- as.character(p$gwasSumStats$study)[[gi]] - gdf <- getSumstatDf(p$gwasSumStats, study = gStudy, require = c("SNP", "Z")) + gdf <- getSumStatsDf( + p$gwasSumStats, + study = gStudy, + require = c("SNP", "Z") + ) twasOut <- .cipComputeTwasZ( weights = weightsInfo$weights, variantIds = weightsInfo$variantIds, @@ -706,7 +710,7 @@ causalInferencePipeline <- function( } # Compute the per-tuple TWAS Z from a single GwasSumStats tuple's -# unpacked data.frame (produced by getSumstatDf upstream). Returns +# unpacked data.frame (produced by getSumStatsDf upstream). Returns # NULL when the overlap is too small. .cipComputeTwasZ <- function( weights, diff --git a/R/colocPipeline.R b/R/colocPipeline.R index 79c9855b..cf8565f5 100644 --- a/R/colocPipeline.R +++ b/R/colocPipeline.R @@ -213,13 +213,11 @@ colocPipeline <- function( .colocValidateEnrichment(p$enrichment) } if (!requireNamespace("coloc", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'coloc' is required for colocPipeline. ", "Install with: install.packages('coloc')." ) abort(msg) - # nocov end } if (!methods::is(p$qtlFineMappingResult, "FineMappingResultBase")) { msg <- glue( diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 733f8fc0..b7965153 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -154,9 +154,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { # Run colocboost() with tryCatch + timing. .cbRun <- function(label, args) { if (!requireNamespace("colocboost", quietly = TRUE)) { - # nocov start abort("The colocboost package is required for colocboostPipeline().") - # nocov end } t1 <- Sys.time() args <- compact(args) @@ -665,7 +663,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { tr <- as.character(ss$trait)[[i]] label <- str_c(st, ctx, tr, sep = ":") pair <- .cbSumstatPair( - df = getSumstatDf( + df = getSumStatsDf( ss, study = st, context = ctx, @@ -696,7 +694,7 @@ setGeneric("colocboostPipeline", function(qtlData, gwasSumStats = NULL, ...) { for (i in seq_len(nrow(gws))) { st <- as.character(gws$study)[[i]] pair <- .cbSumstatPair( - df = getSumstatDf(gws, study = st, require = "Z"), + df = getSumStatsDf(gws, study = st, require = "Z"), ldSketch = ldSketch, varY = if (is_in("varY", .tupleColumnNames(gws))) { gws$varY[[i]] diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index ae1314a3..1c46ff42 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -325,13 +325,11 @@ assembleCtwasInputs <- function( # @noRd .ctwasValidateGwasList <- function(gwasSumStats) { if (!requireNamespace("ctwas", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'ctwas' is required for the cTWAS pipeline. ", "Install from https://github.com/xinhe-lab/ctwas ." ) abort(msg) - # nocov end } if (missing(gwasSumStats) || !methods::is(gwasSumStats, "GwasSumStats")) { msg <- glue( @@ -507,7 +505,7 @@ assembleCtwasInputs <- function( } ldPanel <- ldPanelsByRegion[[ldKey]] ldFileByRegion[[rid]] <- ldKey - zSnpPieces[[rid]] <- .ctwasBuildZSnp(gss) + zSnpPieces[[rid]] <- .ctwasBuildZSnp(gss, ldPanel$snpInfo$id) regionInfoPieces[[rid]] <- .ctwasBuildSingleRegionInfo(rid, gss) snpMap[[rid]] <- .ctwasSnpInfoForGwasBlock(gss, ldPanel$snpInfo) } @@ -651,12 +649,11 @@ estCtwasParam <- function( ... ) { if (!requireNamespace("ctwas", quietly = TRUE)) { - # nocov start abort("Package 'ctwas' is required for estCtwasParam.") - # nocov end } groupPriorVarStructure <- arg_match(groupPriorVarStructure) ncore <- as.integer(ncore) + inputs <- .ctwasResolveLdPaths(inputs) extra <- list(...) zGene <- .ctwasEnsureZGene(inputs, ncore) regionData <- .ctwasAssembleRegionData(inputs, zGene, thin, ncore, extra) @@ -840,10 +837,9 @@ estCtwasParam <- function( #' @export screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { if (!requireNamespace("ctwas", quietly = TRUE)) { - # nocov start abort("Package 'ctwas' is required for screenCtwasRegions.") - # nocov end } + estResult <- .ctwasResolveLdPaths(estResult) # ctwas::screen_regions requires thin = 1 region_data; expand the # thinned set first when assemble_region_data was called with thin < 1 # (matches ctwas_sumstats's own expand-before-screen step). @@ -921,10 +917,9 @@ screenCtwasRegions <- function(estResult, L = 5L, ncore = 1L, ...) { #' @export finemapCtwasRegions <- function(screenResult, L = 5L, ncore = 1L, ...) { if (!requireNamespace("ctwas", quietly = TRUE)) { - # nocov start abort("Package 'ctwas' is required for finemapCtwasRegions.") - # nocov end } + screenResult <- .ctwasResolveLdPaths(screenResult) rd <- screenResult$screened_region_data fmRes <- if (length(rd) == 0L) { list(finemap_res = NULL, susie_alpha_res = NULL) @@ -1020,11 +1015,10 @@ mergeCtwasBoundaryRegions <- function( ncore = 1L, ... ) { - # nocov start if (!requireNamespace("ctwas", quietly = TRUE)) { abort("Package 'ctwas' is required for mergeCtwasBoundaryRegions.") } - # nocov end + finemapResult <- .ctwasResolveLdPaths(finemapResult) fmRes <- finemapResult$finemap_res if (is.null(fmRes) || nrow(fmRes) == 0L) { msg <- glue( @@ -2099,7 +2093,52 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # helper (R/sumstatsQc.R), then projects to ctwas's column shape and # bolts on the `study` column ctwas uses to disambiguate stacked rows. # @noRd -.ctwasBuildZSnp <- function(gwasSumStats) { +# Match variant ids against the LD panel's ids the way every other LD consumer +# in the package does -- by (chrom, pos, allele) with ref/alt swaps tolerated -- +# rather than by exact string identity. +# +# ctwas already harmonizes TWAS weights this way (see +# `.ctwasHarmonizeWeights()` below). The GWAS side used plain string joins, so +# one variant could be kept for the weights and dropped for the z-scores. +# `removeStrandAmbiguous = FALSE` matches `.ldFromSketchMatch()`, the shared +# entry point: the panel defines the frame, so an A/T variant is not discarded +# merely for being palindromic. +# @noRd +.ctwasMatchToPanel <- function(ids, panelIds) { + matchVariants(ids, panelIds, removeStrandAmbiguous = FALSE) +} + +# Put the GWAS z-scores in the LD panel's allele frame. +# +# The z-scores arrive in the GWAS's own frame, while `R`, `variance` and the +# harmonized weights are all in the panel's. Where the two spell a variant with +# its alleles swapped, an exact-string join drops it silently -- it is present +# on both sides, so nothing reports a missing variant and the gene just loses an +# instrument. Matching allele-aware keeps it, and negating its z (with A1/A2 +# swapped to match) is what makes the retained z agree in sign with the LD it +# gets modelled against. Variants with no panel match are left alone; ctwas +# drops them itself when it intersects with `snp_map`. +# @noRd +.ctwasHarmonizeZToPanel <- function(zSnp, panelIds) { + if (nrow(zSnp) == 0L || length(panelIds) == 0L) { + return(zSnp) + } + m <- .ctwasMatchToPanel(zSnp$id, as.character(panelIds)) + if (length(m$idxA) == 0L) { + return(zSnp) + } + zSnp$id[m$idxA] <- as.character(panelIds)[m$idxB] + flip <- m$idxA[m$sign < 0] + if (length(flip) > 0L) { + zSnp$z[flip] <- -zSnp$z[flip] + swapped <- zSnp$A1[flip] + zSnp$A1[flip] <- zSnp$A2[flip] + zSnp$A2[flip] <- swapped + } + zSnp +} + +.ctwasBuildZSnp <- function(gwasSumStats, panelIds) { pieces <- list() for (i in seq_len(nrow(gwasSumStats))) { df <- .entryToSumstatDf(gwasSumStats[[i]], keepChrPrefix = FALSE) @@ -2113,7 +2152,7 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { study = as.character(gwasSumStats$study)[[i]] ) } - bind_rows(pieces) + .ctwasHarmonizeZToPanel(bind_rows(pieces), panelIds) } # Derive the single-row region_info from the LD sketch's snpInfo @@ -2135,6 +2174,17 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { pos <- c(pos, as.integer(GenomicRanges::start(gr))) chrs <- c(chrs, as.character(GenomicRanges::seqnames(gr))) } + # Emptiness is checked FIRST: `pos` and `chrs` are filled from the same + # GRanges in the same loop, so an empty block has zero chromosomes too, + # and the chromosome check below would report it as "spans multiple + # chromosomes ()" -- which is both wrong and unactionable. + if (length(pos) == 0L) { + msg <- glue( + "ctwasPipeline: GwasSumStats block '{regionId}' has no variants ", + "to define region bounds." + ) + abort(msg) + } chr <- unique(as.integer( str_remove(chrs, regex("^chr", ignore_case = TRUE)) )) @@ -2145,13 +2195,6 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) abort(msg) } - if (length(pos) == 0L) { - msg <- glue( - "ctwasPipeline: GwasSumStats block '{regionId}' has no variants ", - "to define region bounds." - ) - abort(msg) - } tibble( region_id = regionId, chrom = chr, @@ -2202,6 +2245,13 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # weights to the correlation scale that ctwas expects. # @noRd .ctwasComputeFullPanelLd <- function(gwasLd) { + # Share the validator with `.ldFromSketch()`, the entry point every other + # pipeline uses. This function cannot use `.ldFromSketch()` itself -- it + # needs the whole panel rather than a matched subset, and returns the + # per-variant variance alongside R -- but skipping the guard meant a NULL + # or non-panel sketch surfaced as "unable to find an inherited method for + # 'getSnpInfo'" instead of saying the LD reference was missing. + .ldFromSketchValidate(gwasLd, "ctwasPipeline") snpInfoCtwas <- .ctwasSnpInfoForBlock(gwasLd) geno <- .ldSketchDosage( gwasLd, @@ -2353,6 +2403,24 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { # z.s) / sqrt(t(wgt) %*% R_wgt %*% wgt), so wgt must be a numeric matrix # (not a vector) and R_wgt must be the LD submatrix over the same SNPs. # +# The panel variants a gene's cis span may reach. +# +# ctwas's compute_gene_z asserts every weight variant exists in the block's +# z_snp$id. An LD sketch covering more than the block (e.g. a whole-chrom +# PLINK2) leaks variants outside it, so intersect with the caller's GWAS +# sumstats variant set when provided. +# +# Allele-aware, not `intersect()`: a swapped spelling is the same variant, +# and dropping it here silently shortens the gene's cis span. +# @noRd +.ctwasPanelSnpsForGwas <- function(panelSnps, gwasSnpIds) { + if (is.null(gwasSnpIds)) { + return(panelSnps) + } + m <- .ctwasMatchToPanel(panelSnps, as.character(gwasSnpIds)) + panelSnps[sort(m$idxA)] +} + # R_wgt is sliced from the cached full-panel LD by SNP ID -- no # per-gene genotype re-extraction. Variants absent from the panel # are dropped from that gene's row set. @@ -2368,20 +2436,12 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { gwasSnpIds = NULL, regionSnpIds = NULL ) { - panelSnps <- rownames(ldPanel$R) - # ctwas's compute_gene_z asserts every weight variant exists in the block's - # z_snp$id. An LD sketch covering more than the block (e.g. a whole-chrom - # PLINK2) leaks variants outside it, so intersect with the caller's GWAS - # sumstats variant set when provided. - # # Two variant sets, because they answer different questions. `gwasSnpIds` is # the GLOBAL set: it bounds the gene's cis SPAN, which has to cover every # block the gene reaches for boundary detection to work. `regionSnpIds` is # this block's own set: it bounds the weight vector actually FITTED, because # ctwas fine-maps one region at a time. - if (!is.null(gwasSnpIds)) { - panelSnps <- intersect(panelSnps, as.character(gwasSnpIds)) - } + panelSnps <- .ctwasPanelSnpsForGwas(rownames(ldPanel$R), gwasSnpIds) ctx <- list( ldPanel = ldPanel, panelSnps = panelSnps, @@ -2653,11 +2713,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (nrow(tl) == 0L) { return(NULL) } - pip <- if (is_in("pip", names(tl))) { - set_names(as.numeric(tl$pip), as.character(tl$variant_id)) - } else { - NULL - } + # `pip` is part of the topLoci schema -- fineMappingRow() requires it on + # any non-empty table, and the zero-row case returned above -- so there is + # no pip-less frame to guard against here. + pip <- set_names(as.numeric(tl$pip), as.character(tl$variant_id)) cs <- .ctwasCsMembership(tl) list(pip = pip, csMembers = cs$csMembers, csPurity = cs$csPurity) } @@ -2721,6 +2780,9 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { } } # Steps 2-3: PIP / CS rescue (only when fineMappingResult was passed). + # Relabel first: the auxiliaries are keyed in the fine-mapping result's + # frame, the vids in the panel's, and every join from here on is exact. + finemapAux <- .ctwasRelabelFinemapAux(finemapAux, vids) mustKeep <- .ctwasMustKeep(vids, finemapAux, csMinCor, minPipCutoff) # Step 4: cap, keeping must-keep variants first. if (length(vids) > maxNumVariants && is.finite(maxNumVariants)) { @@ -2737,6 +2799,53 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { list(vids = vids, w = w) } +# Move a set of variant ids into the frame `vids` uses, leaving ids with no +# match alone. +# @noRd +.ctwasRelabelIds <- function(ids, vids) { + if (length(ids) == 0L) { + return(ids) + } + m <- .ctwasMatchToPanel(ids, vids) + if (length(m$idxA) > 0L) { + ids[m$idxA] <- vids[m$idxB] + } + ids +} + +# Relabel a gene's fine-mapping auxiliaries into the weight/panel frame. +# +# `pip` and `csMembers` are keyed by the fine-mapping result's own spelling of +# a variant, while `vids` arrive harmonized to the LD panel. Where the two +# spell one variant with its alleles swapped, the exact-string joins below -- +# `intersect(csMembers, vids)` and `pip[vids]` -- miss it: the credible-set +# member silently loses its must-keep protection, and its PIP silently reads +# NA so the cap falls back to |w|. The net effect is dropping the variant the +# fine-mapping was most confident about, with nothing reported. +# +# Only the LABEL moves here. A PIP and a credible-set membership do not depend +# on which allele is counted, so unlike the z-scores there is no sign to apply. +# @noRd +.ctwasRelabelFinemapAux <- function(finemapAux, vids) { + if (is.null(finemapAux)) { + return(NULL) + } + if (!is.null(finemapAux$pip)) { + names(finemapAux$pip) <- .ctwasRelabelIds( + names(finemapAux$pip), + vids + ) + } + if (length(finemapAux$csMembers) > 0L) { + finemapAux$csMembers <- map( + finemapAux$csMembers, + .ctwasRelabelIds, + vids = vids + ) + } + finemapAux +} + # Variants that must survive the cap: members of any high-purity (>= csMinCor) # credible set, plus any with PIP > minPipCutoff. Empty when no finemapAux. # @noRd @@ -2808,6 +2917,75 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { ) } +# A cTWAS payload's `LD_file` token does double duty: ctwas asserts the file +# exists, and pecotmr dispatches on the same string into the cached per-region +# LD panels. Both make the token machine-specific, so a payload that was +# serialised (the bundled ctwas*Example objects) carries a path from whatever +# machine built it. Re-point it at this installation on the way in, using the +# same "pecotmr://extdata/" convention the genotype handles use. +# +# The panels themselves travel with the closures and are never re-read, so +# this only has to keep the token and the cache keys agreeing with each other. +# @noRd +.ctwasResolveLdPaths <- function(payload) { + ldMap <- payload$LD_map + # Anything that is not a table with an LD_file column is passed through: + # callers hand the granular steps hand-built payloads whose LD_map may be + # a stub, and there is nothing to re-point in one. + if (!is.list(ldMap) || is.null(ldMap[["LD_file"]])) { + return(payload) + } + stored <- as.character(ldMap[["LD_file"]]) + resolved <- map_chr(stored, .resolveCtwasLdToken) + if (identical(resolved, stored)) { + return(payload) + } + keyMap <- set_names(resolved, stored) + payload$LD_map$LD_file <- unname(resolved) + payload$LD_map$SNP_file <- unname(resolved) + .ctwasRekeyLdLoaders(payload, keyMap) +} + +# Only "pecotmr://" tokens move; an ordinary path is the caller's own and is +# left alone (an unresolvable bundled reference is an error worth hearing). +# @noRd +.resolveCtwasLdToken <- function(token) { + if (!str_detect(token, "^pecotmr://")) { + return(token) + } + .resolveGenotypeResourcePath(token) +} + +# Rebuild the loader closures over a cache re-keyed to the resolved tokens, +# so `LD_loader_fun(LD_file)` still finds its panel after the rename. +# @noRd +.ctwasRekeyLdLoaders <- function(payload, keyMap) { + panels <- .ctwasCachedPanels(payload) + if (is.null(panels)) { + return(payload) + } + hit <- is_in(names(panels), names(keyMap)) + names(panels)[hit] <- unname(keyMap[names(panels)[hit]]) + payload$LD_loader_fun <- .ctwasMultiBlockLdLoader(panels) + payload$snpinfo_loader_fun <- .ctwasMultiBlockSnpInfoLoader(panels) + payload +} + +# The panel cache the loader closures were built over, or NULL when the +# payload carries loaders this package did not create. +# @noRd +.ctwasCachedPanels <- function(payload) { + loader <- payload$LD_loader_fun + if (!is.function(loader)) { + return(NULL) + } + env <- environment(loader) + if (is.null(env) || !exists("ldPanelsByRegion", envir = env)) { + return(NULL) + } + get("ldPanelsByRegion", envir = env) +} + # Multi-block LD loader for ctwas. ctwas invokes # `LD_loader_fun(LD_file)` per region during region_data assembly and # fine-mapping; we dispatch by `LD_file` (the same string set on @@ -2891,8 +3069,10 @@ asCtwasResult <- function(finemapResult, keepSnps = FALSE) { if (length(blockIds) == 0L) { return(panelSnpInfo[FALSE, , drop = FALSE]) } - keep <- is_in(panelSnpInfo$id, blockIds) - panelSnpInfo[keep, , drop = FALSE] + # Allele-aware, not `is_in()`: see `.ctwasMatchToPanel()`. Rows stay in + # panel order, which the ctwas engine indexes positionally. + m <- .ctwasMatchToPanel(panelSnpInfo$id, blockIds) + panelSnpInfo[sort(m$idxA), , drop = FALSE] } # ---- map/apply helpers (lambda-free callbacks) --------------------------- diff --git a/R/exampleData.R b/R/exampleData.R index 07d6785e..19ef9b03 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -669,16 +669,23 @@ NULL #' #' @docType data #' -#' @description A small synthetic \code{LdEigen} reference (per-block LD -#' eigen-decompositions over 20 SNPs in 2 blocks) for the heritability -#' estimators (\code{\link{estimateH2}} with \code{method = "lder"} or -#' \code{"hdl"}, and \code{\link{computeLdScores}}). All identifiers are -#' synthetic. +#' @description An \code{LdEigen} reference for the eigendecomposition-based +#' heritability estimators (\code{\link{estimateH2}} with +#' \code{method = "lder"} or \code{"hdl"}, and +#' \code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} from +#' the first 14 chr22 LD blocks of the de-identified \code{protocol_example} +#' reference panel, so the LD is real rather than simulated. Describes the +#' same variants as \code{\link{ldScoreExample}}, so the four estimators can +#' be compared on one reference. +#' +#' The panel behind it has \code{nRef = 1000}. That is small enough that +#' \code{method = "hdl"}, which models reference-panel noise explicitly, +#' shrinks its estimate hard -- correct behaviour for a panel this size +#' rather than a fault. #' #' @format An \code{LdEigen} object (extends \code{LdStatistic}) with an #' \code{eigenList} of per-block \code{values} / \code{vectors} / -#' \code{snpIdx} -#' over 20 SNPs in 2 LD blocks. +#' \code{snpIdx} over 1300 variants in 14 LD blocks. #' #' @keywords data #' @@ -695,15 +702,21 @@ NULL #' #' @docType data #' -#' @description A small synthetic \code{LdScore} reference (per-SNP LD scores, -#' weights, and per-block LD matrices over 20 SNPs in 2 blocks) for the -#' heritability estimators (\code{\link{estimateH2}} with -#' \code{method = "gldsc"}). All identifiers are synthetic. +#' @description An \code{LdScore} reference (per-variant LD scores, weights, +#' and per-block LD matrices) for the LD-score-based heritability estimators +#' (\code{\link{estimateH2}} with \code{method = "sldsc"} or +#' \code{"gldsc"}). Built by \code{\link{buildLdScore}} from the first 14 +#' chr22 LD blocks of the de-identified \code{protocol_example} reference +#' panel, so the LD is real rather than simulated. Describes the same variants +#' as \code{\link{ldEigenExample}}. +#' +#' The per-block LD matrices are retained because \code{"gldsc"} and +#' stratified \code{"sldsc"} both need them; unstratified \code{"sldsc"} +#' reads only the scores. #' #' @format An \code{LdScore} object (extends \code{LdStatistic}) carrying -#' \code{ldScores}, \code{ldScoreWeights}, and \code{ldMatrixList} over 20 -#' SNPs -#' in 2 LD blocks. +#' \code{ldScores}, \code{ldScoreWeights}, and \code{ldMatrixList} over +#' 1300 variants in 14 LD blocks. #' #' @keywords data #' diff --git a/R/fineMappingRow.R b/R/fineMappingRow.R index 25e4b0b7..fb1ce1e7 100644 --- a/R/fineMappingRow.R +++ b/R/fineMappingRow.R @@ -197,15 +197,14 @@ fineMappingRow <- function(variantIds, susieFit, topLoci, cvResult = NULL) { error = function(e) NULL ) if (is.null(fn)) { - # nocov start (defensive guard against an upstream fsusieR rename; only - # reachable if fsusieR drops this unexported S3 method) + # Defensive guard against an upstream fsusieR rename; only reachable + # if fsusieR drops this unexported S3 method. msg <- glue( "fsusieR's internal update_cal_credible_band.susiF not found; ", "cannot compute the fSuSiE credible band (upstream fsusieR API ", "changed)." ) abort(msg) - # nocov end } indxLst <- fsusieR::gen_wavelet_indx(log2(length(fit$outing_grid))) fn(fit, indxLst) diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index fde45fa3..19cd4134 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -327,6 +327,8 @@ fitSusieInfThenSusieRss <- function( #' @param yScalar Scaling factor for phenotype effects. Default 1. #' @param af Effect-allele frequencies (exported as the \code{af} column; never #' MAF). Default NULL. +#' @param n Optional per-variant sample size, exported as the \code{N} column. +#' Default NULL -> \code{N} falls back to the fit's own scalar sample size. #' @param coverage Primary credible-set coverage. #' @param secondaryCoverage Additional credible-set coverages. #' @param signalCutoff PIP cutoff for including non-CS variants in top loci. @@ -1398,7 +1400,7 @@ buildTopLoci <- function( } # The per-variant N column. Numeric, so a fractional *effective* N (e.g. -# 4 / (1 / nCase + 1 / nControl)) matches getSumstatDf(entry)$N exactly rather +# 4 / (1 / nCase + 1 / nControl)) matches getSumStatsDf(entry)$N exactly rather # than being truncated. With no per-variant n this falls back to the fit's # scalar N (integer nrow on the QTL path, NA otherwise); a scalar n recycles. # @noRd @@ -2207,13 +2209,11 @@ fsusieWrapper <- function( ... ) { if (!requireNamespace("fsusieR", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install fsusieR: ", "https://github.com/stephenslab/fsusieR" ) abort(msg) - # nocov end } fsusieObj <- fsusieR::susiF( X = X, @@ -2738,13 +2738,11 @@ mvsusieWeights <- function( ... ) { if (!requireNamespace("mvsusieR", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'mvsusieR' is required. Install with: ", "devtools::install_github('stephenslab/mvsusieR')" ) abort(msg) - # nocov end } if (is.null(mvsusieFit)) { inform("mvsusieFit is not provided; fitting mvSuSiE now ...") @@ -2917,14 +2915,12 @@ fsusieWeights <- function( # fSuSiE weight reconstruction needs fsusieR + wavethresh. .fsusieWeightsRequire <- function() { - # nocov start if (!requireNamespace("fsusieR", quietly = TRUE)) { abort("Package 'fsusieR' is required for fsusieWeights().") } if (!requireNamespace("wavethresh", quietly = TRUE)) { abort("Package 'wavethresh' is required for fsusieWeights().") } - # nocov end } # A full (untrimmed) fit must retain the wavelet-reconstruction slots. @@ -3063,13 +3059,11 @@ mvsusieRssWeights <- function( ... ) { if (!requireNamespace("mvsusieR", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'mvsusieR' is required. ", "Install with: devtools::install_github('stephenslab/mvsusieR')" ) abort(msg) - # nocov end } if (is.null(mvsusieRssFit)) { mvsusieRssFit <- .mvsusieRssBuildFit( diff --git a/R/genotypeIo.R b/R/genotypeIo.R index 4f4bc3ee..f76688b3 100644 --- a/R/genotypeIo.R +++ b/R/genotypeIo.R @@ -131,14 +131,12 @@ setMethod( #' @keywords internal .makeGdsHandle <- function(path) { - # nocov start if (!requireNamespace("SNPRelate", quietly = TRUE)) { abort("Package 'SNPRelate' is required for reading GDS files.") } if (!requireNamespace("gdsfmt", quietly = TRUE)) { abort("Package 'gdsfmt' is required for reading GDS files.") } - # nocov end if (!file.exists(path)) { msg <- glue("GDS file not found: {path}") abort(msg) @@ -162,11 +160,9 @@ setMethod( #' @keywords internal .makeVcfHandle <- function(path, ...) { - # nocov start if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort("Package 'VariantAnnotation' is required for reading VCF files.") } - # nocov end if (!file.exists(path)) { msg <- glue("VCF file not found: {path}") abort(msg) @@ -206,11 +202,9 @@ setMethod( #' @keywords internal .makePlink1Handle <- function(path, ...) { - # nocov start if (!requireNamespace("snpStats", quietly = TRUE)) { abort("Package 'snpStats' is required for reading plink1 files.") } - # nocov end stem <- .plink1RequireFiles(path) meta <- .plink1ReadMeta(stem) new( @@ -272,11 +266,9 @@ setMethod( #' @keywords internal .makePlink2Handle <- function(path, ...) { - # nocov start if (!requireNamespace("pgenlibr", quietly = TRUE)) { abort("Package 'pgenlibr' is required for reading plink2 files.") } - # nocov end stem <- .plinkStem(path) @@ -934,13 +926,11 @@ readFam <- function(bed) { # open bed/bim/fam: A PLINK 1 .bed is a valid .pgen openBed <- function(bed) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install pgenlibr: ", "https://cran.r-project.org/web/packages/pgenlibr/index.html" ) abort(msg) - # nocov end } rawSCt <- nrow(readFam(bed)) return(pgenlibr::NewPgen(bed, raw_sample_ct = rawSCt)) @@ -1163,13 +1153,11 @@ resolvePlink2Paths <- function(prefix) { #' @noRd readPvar <- function(pvarPath) { if (!requireNamespace("pgenlibr", quietly = TRUE)) { - # nocov start msg <- glue( "pgenlibr is required. Install from ", "https://cran.r-project.org/web/packages/pgenlibr/index.html" ) abort(msg) - # nocov end } pvar <- pgenlibr::NewPvar(pvarPath) on.exit(pgenlibr::ClosePvar(pvar), add = TRUE) diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 876f039b..eb742045 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -398,10 +398,10 @@ setMethod( # getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R). -#' @rdname getSumstatDf +#' @rdname getSumStatsDf #' @export setMethod( - "getSumstatDf", + "getSumStatsDf", "GwasSumStats", function( x, diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 4ce55c99..fc83e9ad 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -276,13 +276,18 @@ shrinkLd <- function( #' @title Validate Genome Build Consistency #' @description Check that genome builds match between objects. Each object -#' contributes a single genome build (from its \code{genome} slot). +#' contributes a single genome build (from its \code{genome} slot). An +#' object that records no build is skipped rather than treated as a +#' mismatch: \code{loadLdMatrix()} leaves the build unset, so an LD +#' reference built from it names no build, and an unknown build cannot +#' contradict a known one. #' @param ... Objects with a \code{genome} slot. #' @return TRUE if all match, error otherwise. #' @keywords internal checkGenomeBuild <- function(...) { objects <- list(...) genomes <- map_chr(objects, .h2GenomeOfObject) + genomes <- genomes[!is.na(genomes)] if (n_distinct(genomes) > 1L) { msg <- glue( "Genome build mismatch: {str_flatten(genomes, ', ')}" @@ -508,6 +513,14 @@ NULL # IRWLS weight w = 1/(1 + predGenetic)^2 * w2(lam); predGenetic uses the current # (clamped) slopes, w2 = pmin(1,lam) (in-sample) or logistic (out-of-sample). .lderWeights <- function(lam, ldAnnot, slopes, N, M, rough) { + # A correlation matrix's eigenvalues cannot be negative, but a real, + # rank-deficient LD block decomposes with a tail of tiny negative values + # (order -1e-15) that are pure floating-point noise. Left alone they make + # `pmin(1, lam)` negative, and the IRWLS step then takes sqrt() of a + # negative weight -- NaN designs and an "NA/NaN/Inf in 'x'" abort from + # lm.fit. Clamping at zero drops those null directions from the fit, + # which is what a zero-information direction should contribute anyway. + lam <- pmax(lam, 0) predG <- lam * as.vector(ldAnnot %*% pmin(pmax(slopes, 0), N / M)) w2 <- if (rough) 1 / (1 + exp(-5 * (lam - 1))) else pmin(1, lam) 1 / (1 + predG)^2 * w2 @@ -1146,7 +1159,13 @@ NULL # s_i = (ldAnnotScaled %*% h2a)_i and h2Total = sum(h2a). With a single 1/M # score column this is exactly upstream HDL's llfun (Ning et al. 2020). # param = c(h2_1, .., h2_nTau, int). -.hdlNll <- function(param, n, nRef, lam, bstar, ldAnnotScaled, lim = exp(-18)) { +# `lim` is upstream HDL's floor on the modelled per-direction variance +# (llfun.R uses exp(-10)). It has to match: with 40% of a real reference's +# eigen-directions near zero the floor is active for most of them, and the +# `bstar^2 / lamh2` term it feeds dominates the likelihood -- a smaller floor +# changes the objective by orders of magnitude and moves the optimum. +# @noRd +.hdlNll <- function(param, n, nRef, lam, bstar, ldAnnotScaled, lim = exp(-10)) { nTau <- ncol(ldAnnotScaled) h2a <- param[seq_len(nTau)] int <- param[nTau + 1L] @@ -1210,8 +1229,10 @@ NULL # Fit HDL by L-BFGS-B over (h2_1..h2_nTau, int); bounds h2_a in [0,1], int in # [0,10] (Ning et al. 2020). Parametrizing by per-annotation h2 (scale ~1) # keeps the L-BFGS-B finite differences well conditioned. -.hdlFit <- function(design, n, nRef) { +.hdlFit <- function(design, n, nRef, warnOnBound = TRUE) { nTau <- ncol(design$ldAnnotScaled) + lower <- c(rep(0, nTau), 0) + upper <- c(rep(1, nTau), 10) opt <- optim( c(rep(0.1, nTau), 1), .hdlNll, @@ -1221,16 +1242,58 @@ NULL bstar = design$bstar, ldAnnotScaled = design$ldAnnotScaled, method = "L-BFGS-B", - lower = c(rep(0, nTau), 0), - upper = c(rep(1, nTau), 10) + lower = lower, + upper = upper ) + if (warnOnBound) { + .hdlWarnIfAtBound(opt$par, lower, upper, n, nRef) + } h2a <- opt$par[seq_len(nTau)] list(h2a = h2a, int = opt$par[nTau + 1L], h2 = sum(h2a)) } +# HDL's likelihood carries a finite-reference term, -lam * h2 / nRef, that +# subtracts from the modelled variance. Once the reference is small enough +# relative to the GWAS, that term outgrows the signal term, the modelled +# variance is driven negative across most directions, and the optimiser walks +# the intercept out to its upper bound. The heritability that comes back then +# reflects the boundary rather than the data -- on the bundled reference, +# nRef = 1000 against N = 1e5 returns 0.08 for a true 0.4 with the intercept +# pinned at 10. +# +# It is a silent failure otherwise, and a detectable one: say so. +# +# Only the UPPER bounds are diagnostic. An intercept pinned at 0 simply means +# no inflation was detected and leaves the heritability sound -- it happens +# routinely on a well-sized reference -- and a heritability of 0 is a +# legitimate estimate for a null trait. Warning on those would fire on +# healthy fits and train the reader to ignore the message. +# @noRd +.hdlWarnIfAtBound <- function(par, lower, upper, n, nRef) { + tol <- 1e-6 + atUpper <- par >= upper - tol + if (!any(atUpper)) { + return(invisible(FALSE)) + } + which <- if (atUpper[[length(atUpper)]]) { + "intercept" + } else { + "heritability" + } + warn(glue( + "HDL: the fitted {which} sits at the top of its range, so the ", + "estimate reflects that bound rather than the data. This usually ", + "means the LD reference is too small for the GWAS -- the ", + "finite-reference correction scales as 1/nRef, and here nRef = ", + "{nRef} against N = {round(n)}. Compare the other estimators, or ", + "use a larger reference panel." + )) + invisible(TRUE) +} + # Baseline modeled variance lamh2_i at the fitted parameters (for local h2 and # the sHDL candidate score test). -.hdlBaselineVar <- function(design, ft, n, nRef, lim = exp(-18)) { +.hdlBaselineVar <- function(design, ft, n, nRef, lim = exp(-10)) { s <- as.vector(design$ldAnnotScaled %*% ft$h2a) pmax( s * design$lam^2 - design$lam * ft$h2 / nRef + ft$int * design$lam / n, @@ -1288,7 +1351,7 @@ NULL # Local h2 for one block: MLE of the block's genome-wide-scaled h2 with the # intercept fixed at the global fit; SE from the Gaussian-variance Fisher # information sum((dlamh2/dh2)^2 / (2 lamh2^2)). -.hdlLocalBlock <- function(bd, b, n, nRef, int, M, lim = exp(-18)) { +.hdlLocalBlock <- function(bd, b, n, nRef, int, M, lim = exp(-10)) { varOf <- function(h2) { pmax(h2 / M * bd$lam^2 - h2 * bd$lam / nRef + int * bd$lam / n, lim) } @@ -1453,6 +1516,415 @@ hdlUnivariate <- function( #' @importFrom stats median NULL +# ============================================================================= +# S-LDSC (Finucane et al. 2015) -- stratified LD score regression +# ----------------------------------------------------------------------------- +# The original method the other three descend from. It regresses per-variant +# chi-square on annotation-stratified LD scores: +# +# E[chi2_j] = N * sum_C tau_C * l(j, C) + N*a + 1 +# with l(j, C) = sum_{k in C} r2_jk +# +# Unlike g-LDSC it needs only the per-variant scores, not the per-block LD +# matrices, so an unstratified run works off a scores-only LdScore. The +# stratified run needs the matrices, since the per-annotation scores are +# formed from them exactly as g-LDSC forms its own. +# ============================================================================= + +#' @title S-LDSC: Stratified LD Score Regression +#' @description Estimate heritability and functional enrichment by weighted +#' least squares on LD scores (Finucane et al. 2015) -- the original method +#' the other three estimators descend from. Per-variant \eqn{\chi^2_j} is +#' regressed on annotation-stratified LD scores +#' \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}} with a confounding +#' intercept, fitting +#' \eqn{E[\chi^2_j] = N \sum_C \tau_C \ell_{jC} + Na + 1}. +#' +#' Weights are LDSC's two multiplied factors, both floored at 1: the +#' heteroskedasticity term \eqn{1 / (2 E[\chi^2_j]^2)}, iterated on the +#' fitted values, and the overcounting term \eqn{1 / \ell_j} that stops +#' variants in strong LD from being counted many times. Standard errors come +#' from a delete-one-block jackknife over the LD blocks. +#' +#' Two routes are taken, matching \code{ldsc.py} -- the split is on +#' annotation count, not on preference: +#' \describe{ +#' \item{unstratified}{the two-step estimator: the intercept is fit on +#' the variants with \eqn{\chi^2 < 30}, then held fixed while the +#' slope is fit over all of them.} +#' \item{stratified}{no two-step -- upstream refuses one on a +#' partitioned design. Variants with \eqn{\chi^2 >} \code{max(0.001 +#' N, 80)} are dropped, the design is weighted once, and a single +#' weighted least-squares fit follows.} +#' } +#' +#' The intercept is reported as estimated and is not floored at 1: the +#' model implies at least 1, but a value below it is informative rather +#' than an error to clamp away, and clamping would move the heritability +#' too. +#' +#' Estimates agree with upstream \code{ldsc} to roughly 1e-6 relative; +#' the residual is a small ridge in the weighted solve, which upstream has +#' no equivalent of and which exists so an exactly singular design returns +#' a value rather than \code{NA}. +#' +#' Unlike \code{\link{pecotmr-h2-gldsc}} this needs only the per-variant +#' scores when unstratified, so it runs on a scores-only +#' \code{\link{LdScore}}; the stratified fit forms per-annotation scores +#' from the per-block LD matrices and therefore requires them. +#' +#' \strong{Scale.} LD score regression is a genome-scale method -- real +#' analyses regress over roughly a million variants. On a reference of a +#' few thousand the intercept is not identifiable (an unweighted OLS on +#' such data returns an intercept several times its true value), and the +#' heritability estimate is attenuated as a result. Treat small-reference +#' estimates as illustrative. \code{\link{pecotmr-h2-lder}} is much less +#' sensitive to reference size and is the better choice there. +#' @name pecotmr-h2-sldsc +#' @keywords internal +#' @references +#' Finucane HK, Bulik-Sullivan B, Gusev A, et al. (2015). Partitioning +#' heritability by functional annotation using genome-wide association +#' summary statistics. Nature Genetics 47(11):1228-1235. +NULL + +# @noRd +sldscUnivariate <- function( + z, + n, + ldRef, + annotations = NULL, + local = FALSE, + nIter = 2L +) { + 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. + A <- .gldscAnnotMatrix(annotations, M) + scores <- .sldscScoreMatrix(ldRef, baselineMat, M) + baseScore <- scores[, 1L] + blockIdx <- .sldscBlockIndex(ldRef, M) + 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) +} + +# The design's LD-score columns: the base score first, then one stratified +# score per baseline annotation. Stratified scores come from the per-block LD +# matrices, the same source g-LDSC uses. +# @noRd +.sldscScoreMatrix <- function(ldRef, baselineMat, M) { + base <- as.vector(getLdScores(ldRef)[, 1L]) + if (is.null(baselineMat)) { + return(matrix(base, ncol = 1L, dimnames = list(NULL, "base_l2"))) + } + ldMatrixList <- getLdMatrixList(ldRef) + if (length(ldMatrixList) == 0L) { + msg <- glue( + "stratified S-LDSC requires full per-block LD matrices ", + "(ldMatrixList) to form the per-annotation LD scores. Build the ", + "reference with `buildLdScore(keepLdMatrices = TRUE)`." + ) + abort(msg) + } + strat <- matrix(0, M, ncol(baselineMat)) + for (block in ldMatrixList) { + idx <- block$snpIdx + strat[idx, ] <- (block$R^2) %*% baselineMat[idx, , drop = FALSE] + } + cbind(base_l2 = base, strat) +} + +# Per-block variant indices, from the LD matrices when present and otherwise +# by overlapping the reference's variants with its LD blocks. The jackknife +# leaves one of these out at a time. +# @noRd +.sldscBlockIndex <- function(ldRef, M) { + ldMatrixList <- getLdMatrixList(ldRef) + if (length(ldMatrixList) > 0L) { + return(map(ldMatrixList, "snpIdx")) + } + snpInfo <- tibble( + CHR = as.character(seqnames(ldRef)), + BP = start(ldRef) + ) + idx <- snpsPerBlock(snpInfo, getLdBlocks(ldRef)) + keep <- idx[map_int(idx, length) > 0L] + if (length(keep) == 0L) { + abort("S-LDSC: no LD block covers any reference variant.") + } + keep +} + +# Upstream `Hsq.weights` verbatim (ldsc/ldscore/regressions.py): +# +# hsq = clamp(hsq, 0, 1) +# ld = max(ld, 1); w_ld = max(w_ld, 1) +# c = hsq * N / M +# het_w = 1 / (2 (intercept + c*ld)^2) +# w = het_w / w_ld +# +# `ld` is the LD score entering the model and `w_ld` the one computed over +# just the regression variants. pecotmr carries a single score, so both read +# the same column -- also the usual case upstream, where --w-ld-chr names the +# same file as --ref-ld-chr. +# @noRd +.sldscWeights <- function(ld, wLd, n, M, hsq, intercept) { + hsq <- min(max(hsq, 0), 1) + ld <- pmax(ld, 1) + wLd <- pmax(wLd, 1) + hetW <- 1 / (2 * (intercept + (hsq * n / M) * ld)^2) + hetW / wLd +} + +# LDSC's `aggregate`: the method-of-moments h2 that seeds the first weights. +# h2 = M (mean(chi2) - intercept) / mean(N * ld) +# @noRd +.sldscAggregateH2 <- function(chi2, baseScore, n, M, intercept = 1) { + M * (mean(chi2) - intercept) / mean(n * baseScore) +} + +# Upstream takes two different routes and the split is on annotation count, +# not on preference (ldscore/sumstats.py): +# +# univariate -- two-step estimator, chi2 < 30 selects step 1, IRWLS twice +# partitioned -- NO two-step; it raises rather than attempt one. Variants +# with chi2 > max(0.001*N, 80) are dropped outright, the +# design is weighted once by the initial weights, and a plain +# least-squares jackknife follows (its `old_weights` path). +# +# Both are reproduced so the estimates line up with `ldsc.py`. +# @noRd +.sldscFit <- function(chi2, scores, baseScore, n, A, nIter) { + if (ncol(scores) == 1L) { + return(.sldscFitUnivariate(chi2, scores, baseScore, n, A, nIter)) + } + .sldscFitPartitioned(chi2, scores, baseScore, n, A) +} + +# @noRd +.sldscFitUnivariate <- function(chi2, scores, baseScore, n, A, nIter) { + M <- nrow(A) + keep <- chi2 < 30 + if (sum(keep) < 4L) { + keep <- rep(TRUE, length(chi2)) + } + # One set of initial weights, formed on the full data, reused by both + # steps -- upstream computes `initial_w` once and subsets it for step 1. + xTot <- rowSums(scores) + aggH2 <- .sldscAggregateH2(chi2, xTot, n, M) + w0 <- .sldscWeights(xTot, baseScore, n, M, aggH2, 1) + step1 <- .sldscIrwls( + chi2[keep], + scores[keep, , drop = FALSE], + baseScore[keep], + n, + M, + nIter, + freeIntercept = TRUE, + w0 = w0[keep] + ) + # Not floored at 1. The model implies an intercept of at least 1, but + # upstream reports whatever step 1 estimates -- a value below 1 is + # informative (it says the data are inconsistent with the model, often + # deflation) and clamping it silently would change the h2 as well. + intercept <- step1$intercept + step2 <- .sldscIrwls( + chi2 - intercept, + scores, + baseScore, + n, + M, + nIter, + freeIntercept = FALSE, + intercept = intercept, + w0 = w0 + ) + .sldscCoefToFit(c(step2$coef, intercept), n, A) +} + +# @noRd +.sldscFitPartitioned <- function(chi2, scores, baseScore, n, A) { + M <- nrow(A) + keep <- chi2 < max(0.001 * n, 80) + if (sum(keep) < ncol(scores) + 2L) { + keep <- rep(TRUE, length(chi2)) + } + chi2 <- chi2[keep] + scores <- scores[keep, , drop = FALSE] + baseScore <- baseScore[keep] + # `x_tot` upstream: the row-sum of the design's annotation columns, which + # coincides with the base score only when there is a single column. + xTot <- rowSums(scores) + hsq <- .sldscAggregateH2(chi2, xTot, n, M) + w <- .sldscWeights(xTot, baseScore, n, M, hsq, 1) + .sldscCoefToFit(.sldscWlsCoef(cbind(scores, 1), chi2, w), n, A) +} + +# Two IRWLS passes, matching upstream's `for i in range(2)`. +# @noRd +.sldscIrwls <- function( + y, + scores, + baseScore, + n, + M, + nIter, + freeIntercept, + intercept = 1, + w0 = NULL +) { + design <- if (freeIntercept) cbind(scores, 1) else scores + xTot <- rowSums(scores) + if (is.null(w0)) { + hsq <- .sldscAggregateH2(y, xTot, n, M) + w0 <- .sldscWeights(xTot, baseScore, n, M, hsq, intercept) + } + w <- w0 + coef <- NULL + for (i in seq_len(max(1L, nIter))) { + coef <- .sldscWlsCoef(design, y, w) + # Upstream builds the weight from the FIRST coefficient and `x_tot` + # alone -- a univariate approximation even for a partitioned design -- + # rather than from the full fitted values. + hsq <- M * coef[[1L]] / n + if (freeIntercept) { + intercept <- max(coef[[length(coef)]], 0) + } + w <- .sldscWeights(xTot, baseScore, n, M, hsq, intercept) + } + # Upstream's loop updates the weights `nIter` times and then solves once + # more with the converged weights -- three solves for its two passes, not + # two. Stopping at the loop's last solve leaves the final weight update + # unused and shifts the estimate by around a percent. + coef <- .sldscWlsCoef(design, y, w) + list( + coef = coef[seq_len(ncol(scores))], + intercept = if (freeIntercept) coef[[length(coef)]] else intercept + ) +} + + +# Solved through ridge-regularised normal equations rather than lm.fit. The +# base LD-score column is the sum of the stratified ones whenever the baseline +# annotations partition the genome, which makes the design exactly singular; +# lm.fit then returns NA coefficients that poison the next IRWLS weight. The +# ridge is the same negligible one g-LDSC uses for the same reason. +# @noRd +.sldscWlsCoef <- function(design, y, w) { + sw <- sqrt(pmax(w, 0)) + x <- design * sw + xtx <- crossprod(x) + ridge <- 1e-8 * mean(abs(diag(xtx))) + as.vector(solve(xtx + diag(ridge, ncol(xtx)), crossprod(x, y * sw))) +} + +# Regressing chi2 on raw LD scores gives coef_C = N * tau_C, so tau = coef/N. +# Partitioned heritabilities are A'A tau, not tau * M_C: annotations overlap +# in general (the all-ones base column overlaps every one of them), and the +# overlap matrix is what turns per-annotation effects into per-annotation +# heritability. Its leading entry is the total, since A[, 1] is all ones. +# @noRd +.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, + intercept = coef[[nS + 1L]], + coef = coef + ) +} + +# Delete-one-block jackknife over the LD blocks. +# @noRd +.sldscJackknife <- function(chi2, scores, baseScore, n, A, nIter, blockIdx) { + loo <- map( + blockIdx, + .sldscLooFit, + chi2 = chi2, + scores = scores, + baseScore = baseScore, + n = n, + A = A, + nIter = nIter + ) + tauBlocks <- exec(rbind, !!!map(loo, "tau")) + estHBlocks <- exec(rbind, !!!map(loo, "estH")) + intLoo <- map_dbl(loo, "intercept") + nB <- length(loo) + jkSe <- function(v) sqrt(var(v) * (nB - 1)^2 / nB) + list( + h2Se = jkSe(estHBlocks[, 1L]), + intSe = jkSe(intLoo), + tauSe = apply(tauBlocks, 2, jkSe), + tauBlocks = tauBlocks, + estHBlocks = estHBlocks + ) +} + +# The left-out block is dropped from the regression rows, but `A` stays whole: +# the annotation sizes are genome-wide constants, not per-fold quantities. +# @noRd +.sldscLooFit <- function(idx, chi2, scores, baseScore, n, A, nIter) { + keep <- setdiff(seq_along(chi2), idx) + .sldscFit( + chi2[keep], + scores[keep, , drop = FALSE], + baseScore[keep], + n, + A, + nIter + ) +} + +# @noRd +.sldscResult <- function( + fit, + jk, + annotations, + baselineMat, + chi2, + baseScore, + local, + M +) { + localDf <- if (local) .sldscLocal(chi2, baseScore, fit, M) else NULL + enrichmentDf <- NULL + if (!is.null(baselineMat)) { + nm <- SummarizedExperiment::colData(getBaseline(annotations))$name + enrichmentDf <- .gldscEnrichmentDf(fit, jk, baselineMat, nm, 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, + tauBlocks = if (is.null(baselineMat)) { + NULL + } else { + jk$tauBlocks[, -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 +.sldscLocal <- function(chi2, baseScore, fit, M) { + tibble( + variantIdx = seq_along(chi2), + chi2 = chi2, + ldScore = baseScore, + h2Local = fit$tau[[1L]] * pmax(baseScore, 0) + ) +} + # ============================================================================= # estimateH2 -- main dispatch # ============================================================================= @@ -1486,10 +1958,87 @@ NULL method, "lder" = lderUnivariate(z, n, ldRef, annotations, local, ...), "gldsc" = gldscUnivariate(z, n, ldRef, annotations, local, ...), + "sldsc" = sldscUnivariate(z, n, ldRef, annotations, local, ...), "hdl" = hdlUnivariate(z, n, ldRef, annotations, local, ...) ) } +# The estimators read `z` and the annotation rows positionally, by each LD +# block's own snpIdx -- nothing is matched on variant id along the way. A +# sumstats or annotation set that is not the reference's variant list, in the +# reference's order, therefore yields a silently wrong h2 rather than an +# error. This is the one place holding all three objects, so check here. +# @noRd +.h2ValidateInputs <- function(sumstats, study, ldRef, annotations) { + checkGenomeBuild(sumstats, ldRef) + .h2CheckBlockCount(ldRef) + entry <- getSumStats(sumstats, study = study) + .h2CheckVariantCount(length(entry), length(ldRef), glue("study '{study}'")) + .h2CheckPositions(entry, ldRef, study) + if (is.null(annotations)) { + return(invisible(TRUE)) + } + checkGenomeBuild(ldRef, annotations) + .h2CheckVariantCount(nrow(annotations), length(ldRef), "`annotations`") + invisible(TRUE) +} + +# Every estimator takes its standard error from a delete-one-block jackknife, +# which needs at least two blocks. With one, LDER and g-LDSC fail deep inside +# a fold fit ("'x' must be a matrix") and HDL reports an SE of exactly 0, so +# say so here instead. +# @noRd +.h2CheckBlockCount <- function(ldRef) { + nBlocks <- length(getLdBlocks(ldRef)) + if (nBlocks >= 2L) { + return(invisible(TRUE)) + } + msg <- glue( + "estimateH2: the LD reference carries {nBlocks} LD block(s). The ", + "estimators take their standard error from a delete-one-block ", + "jackknife, so at least two are required, and a usable SE needs ", + "many more. Build the reference from per-block LD -- see ", + "`buildLdEigen()` / `buildLdScore()`." + ) + abort(msg) +} + +# @noRd +.h2CheckVariantCount <- function(n, M, what) { + if (n == M) { + return(invisible(TRUE)) + } + msg <- glue( + "estimateH2: {what} carries {n} variant(s) but the LD reference ", + "carries {M}. The estimators index by the reference's variant ", + "order, so both must hold the same variants in the same order." + ) + 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 once the chr prefix is normalized. +# @noRd +.h2CheckPositions <- function(entry, ldRef, study) { + same <- withChrPrefix(as.character(seqnames(entry))) == + withChrPrefix(as.character(seqnames(ldRef))) & + start(entry) == start(ldRef) + if (all(same)) { + return(invisible(TRUE)) + } + nBad <- sum(!same) + firstBad <- which(!same)[[1L]] + msg <- glue( + "estimateH2: study '{study}' 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." + ) + abort(msg) +} + # Wrap a univariate estimator result list into an H2Estimate S4 object. .h2EstimateFromResult <- function(result, method, M, study) { new( @@ -1522,9 +2071,10 @@ setMethod( study = NULL, ... ) { - method <- arg_match(method, c("lder", "gldsc", "hdl")) + method <- arg_match(method, c("lder", "gldsc", "sldsc", "hdl")) .validateMethodRef(method, ldRef) study <- .estimateH2ResolveStudy(sumstats, study) + .h2ValidateInputs(sumstats, study, ldRef, annotations) z <- getZ(sumstats, study = study) n <- median(getN(sumstats, study = study)) M <- nSnps(sumstats, study = study) @@ -1556,9 +2106,10 @@ setMethod( ) abort(msg) } - if (method == "gldsc" && !is(ldRef, "LdScore")) { + if (is_in(method, c("gldsc", "sldsc")) && !is(ldRef, "LdScore")) { msg <- glue( - "Method 'gldsc' requires an LdScore object, got {class(ldRef)}" + "Method '{method}' requires an LdScore object, ", + "got {class(ldRef)}" ) abort(msg) } @@ -1766,13 +2317,20 @@ h2EstimateToSldscTrait <- function(h2Est) { } } -# The single build named by a GRanges' seqinfo, or an error saying it carries -# none -- silently returning NA would make a mismatch check pass by accident. +# The single build named by a GRanges' seqinfo. A GRanges naming none returns +# NA and checkGenomeBuild() skips it: loadLdMatrix() leaves the build unset, +# so demanding one here would reject every LD reference the package's own +# loader produces. Naming more than one is still an error -- such an object +# is internally inconsistent rather than merely unlabelled, and the +# coordinate check in .h2CheckPositions() is the stronger guard regardless. # @noRd .h2GenomeOfRanges <- function(x) { g <- unique(GenomeInfoDb::genome(x)) g <- g[!is.na(g)] - if (length(g) != 1L) { + if (length(g) == 0L) { + return(NA_character_) + } + if (length(g) > 1L) { abort(glue( "genome build check: the GRanges names {length(g)} genome ", "build(s) in seqinfo(); set one with genome(x) <- \"hg38\"." @@ -1856,7 +2414,14 @@ h2EstimateToSldscTrait <- function(h2Est) { # One HDL delete-one-block jackknife fold: refit leaving block `b` out. # @noRd .hdlLooFit <- function(b, blockData, M, baselineMat, n, nRef) { - .hdlFit(.hdlDesign(blockData[-b], M, baselineMat), n, nRef) + # The full-data fit already reported any bound it hit; repeating that + # once per left-out block would bury it in noise. + .hdlFit( + .hdlDesign(blockData[-b], M, baselineMat), + n, + nRef, + warnOnBound = FALSE + ) } # One HDL local-heritability row for block `b`. diff --git a/R/jointEngine.R b/R/jointEngine.R index 3c14a321..909d3fae 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -125,7 +125,12 @@ NULL return(GenomicRanges::granges(rr[trait])[1L]) } if (methods::is(data, "QtlSumStats")) { - if (!is_in("traitPos", names(data))) { + # colnames(), not names(): a collection's names() are its GRangesList + # ELEMENT names (empty here), while the per-row columns live in mcols. + # Reading names() made this guard always fire, so the whole branch + # below was dead and every sumstats-derived row fell back to the + # chrUn sentinel instead of its real trait position. + if (!is_in("traitPos", colnames(data))) { return(NULL) } idx <- which( @@ -135,10 +140,9 @@ NULL if (length(idx) == 0L) { return(NULL) } + # traitPos is a GRanges column and `idx` came from which(), so this + # is always a length-1 range. tp <- data$traitPos[idx[[1L]]] - if (length(tp) == 0L) { - return(NULL) - } return(GenomicRanges::granges(tp)[1L]) } NULL @@ -786,7 +790,7 @@ setMethod( ) { ma[[adapter$fitArg]] <- fittedModels[[token]] } - if (isTRUE(cfg$estimatePi) && is_in(token, c("bayes_c", "bayes_b"))) { + if (isTRUE(cfg$estimatePi) && is_in(token, c("bayesC", "bayesB"))) { ma <- .jointTwasSpikeSlabPi(ma, token, Xc, Yc, cond, cfg, stdz) } ma @@ -809,10 +813,10 @@ setMethod( seed = cfg$seed ) piHat <- as.numeric(estimateSparsity(mrA)) - if (token == "bayes_c" && is.null(ma$pi)) { + if (token == "bayesC" && is.null(ma$pi)) { ma$pi <- piHat } - if (token == "bayes_b" && is.null(ma$probIn)) { + if (token == "bayesB" && is.null(ma$probIn)) { ma$probIn <- piHat } ma diff --git a/R/jointSpecification.R b/R/jointSpecification.R index d29e59e0..72d7b6a4 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -1010,7 +1010,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { context = as.character(data$context), trait = as.character(data$trait) ) - firstDf <- getSumstatDf( + firstDf <- getSumStatsDf( data, study = cols$study[[tupleRows[[1L]]]], context = cols$context[[tupleRows[[1L]]]], @@ -1057,7 +1057,7 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { nVec <- numeric(length(tupleRows)) for (kk in seq_along(tupleRows)) { i <- tupleRows[[kk]] - d <- getSumstatDf( + d <- getSumStatsDf( data, study = cols$study[[i]], context = cols$context[[i]], diff --git a/R/ld.R b/R/ld.R index e3cbdad3..aa868842 100644 --- a/R/ld.R +++ b/R/ld.R @@ -434,6 +434,22 @@ createLdMatrix <- function(ldMatrices, variants) { #' @param ldMetaFilePath Path to the LD metadata TSV file. #' @param region Region of interest: "chr:start-end" string or data.frame with #' chrom/start/end. +#' @param block Integer block index (or vector of them), for sources that +#' carry no coordinates: an \code{ldInfo} table (the cTWAS \code{LD_map} +#' shape -- an \code{LD_file} column and optionally \code{SNP_file}), a +#' correlation or genotype matrix, or a list of either. Supply exactly one +#' of \code{region} and \code{block}. +#' @param dropMonomorphic Logical. Drop variants with no variation, which +#' carry no LD and make a correlation undefined. Needs allele frequencies, +#' so it applies to genotype sources. +#' @param materializeGenotypes Logical. Read the dosages once and keep them on +#' the returned object, so later access does no file I/O. Costs memory and +#' saves repeated reads. +#' @param maxVariants Integer or \code{NULL}. Randomly thin any block larger +#' than this, to bound memory. +#' @param seed Integer or \code{NULL}. Seeds the \code{maxVariants} draw, +#' offset by the block index so blocks are independent yet reproducible, via +#' a scoped \code{withr::local_seed} that leaves the session RNG alone. #' @param extractCoordinates Optional data.frame with columns "chrom" and "pos" #' for specific coordinates extraction (only for pre-computed LD blocks). #' @param returnGenotype Controls what ldMatrix contains in the return value. @@ -462,13 +478,291 @@ createLdMatrix <- function(ldMatrices, variants) { #' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", #' package = "pecotmr") #' loadLdMatrix(ldMetaFilePath = meta, region = "chr22:16000000-18000000") +#' # Several regions at once return one LdData per block. +#' length(loadLdMatrix(meta, region = rep("chr22:16000000-18000000", 2))) #' @export loadLdMatrix <- function( ldMetaFilePath, - region, + region = NULL, + block = NULL, extractCoordinates = NULL, returnGenotype = FALSE, + dropMonomorphic = FALSE, + materializeGenotypes = FALSE, + maxVariants = NULL, + seed = NULL, nSample = NULL +) { + .ldLoadValidateAddress(ldMetaFilePath, region, block) + keys <- if (is.null(region)) block else region + # Only an atomic vector addresses several blocks. `region` also accepts a + # single data.frame / GRanges spec, whose length is its column count -- + # treating that as many keys would map over the columns. + if (is.atomic(keys) && length(keys) > 1L) { + return(map( + keys, + .loadLdOne, + source = ldMetaFilePath, + byRegion = is.null(block), + extractCoordinates = extractCoordinates, + returnGenotype = returnGenotype, + dropMonomorphic = dropMonomorphic, + materializeGenotypes = materializeGenotypes, + maxVariants = maxVariants, + seed = seed, + nSample = nSample + )) + } + .loadLdOne( + keys, + ldMetaFilePath, + byRegion = is.null(block), + extractCoordinates = extractCoordinates, + returnGenotype = returnGenotype, + dropMonomorphic = dropMonomorphic, + materializeGenotypes = materializeGenotypes, + maxVariants = maxVariants, + seed = seed, + nSample = nSample + ) +} + +# A source is addressed either by genomic region (an LD meta file, which +# carries coordinates) or by block index (an `ldInfo` table or in-memory +# matrices, which do not). Exactly one addressing mode applies. +# @noRd +.ldLoadValidateAddress <- function(source, region, block) { + if (is.null(region) && is.null(block)) { + abort("loadLdMatrix: supply either `region` or `block`.") + } + if (!is.null(region) && !is.null(block)) { + abort("loadLdMatrix: supply `region` or `block`, not both.") + } + if (!is.null(region) && !is.character(source)) { + msg <- glue( + "loadLdMatrix: `region` addresses an LD meta file, but ", + "`ldMetaFilePath` is a {class(source)[[1L]]}. Coordinate-free ", + "sources (an `ldInfo` table, a matrix, or a list of matrices) ", + "are addressed with `block`." + ) + abort(msg) + } + invisible(TRUE) +} + +# One block, whatever the source. Everything that is not an LD meta file is +# coordinate-free and indexed by `block`. +# @noRd +.loadLdOne <- function( + key, + source, + byRegion, + extractCoordinates, + returnGenotype, + dropMonomorphic, + materializeGenotypes, + maxVariants, + seed, + nSample +) { + result <- if (byRegion) { + .loadLdFromMeta( + source, + key, + extractCoordinates, + returnGenotype, + nSample + ) + } else { + .loadLdFromIndexed(source, key, returnGenotype) + } + result <- .loadLdDedup(result) + result <- .ldApplyMonomorphic(result, dropMonomorphic) + result <- .ldApplySubsample(result, maxVariants, seed, key) + .ldApplyMaterialize(result, materializeGenotypes) +} + +# Coordinate-free sources, addressed by block index: an `ldInfo` table (the +# cTWAS LD_map shape -- LD_file plus optional SNP_file, no coordinates), a +# single in-memory matrix, or a list of them. Every source returns an LdData, +# so callers never have to branch on what they loaded from. +# @noRd +.loadLdFromIndexed <- function(source, block, returnGenotype) { + if (is.data.frame(source)) { + return(.ldInfoBlock(source, block)) + } + mat <- if (is.list(source)) source[[block]] else source + if (!is.matrix(mat)) { + msg <- glue( + "loadLdMatrix: cannot address a {class(source)[[1L]]} by block. ", + "Supply an LD meta file path, an `ldInfo` data.frame, a matrix, ", + "or a list of matrices." + ) + abort(msg) + } + .ldDataFromMatrix(mat, isGenotype = nrow(mat) > ncol(mat)) +} + +# One row of an `ldInfo` table. Genotype paths are read and correlated; +# pre-computed .cor.xz blocks are read directly. +# @noRd +.ldInfoBlock <- function(ldInfo, block) { + if (!is_in("LD_file", colnames(ldInfo))) { + abort("loadLdMatrix: an `ldInfo` table needs an `LD_file` column.") + } + ldPath <- as.character(ldInfo$LD_file)[block] + if (isGenotypeSource(ldPath)) { + geno <- loadGenotypeRegion(ldPath) + return(.ldDataFromMatrix(geno, isGenotype = TRUE)) + } + snpFile <- if (is_in("SNP_file", colnames(ldInfo))) { + as.character(ldInfo$SNP_file)[block] + } else { + NULL # processLdMatrix auto-detects the .bim / .pvar companion + } + .ldDataFromProcessed(processLdMatrix(ldPath, snpFile)) +} + +# Wrap processLdMatrix()'s (matrix, variants) pair as an LdData so BOTH +# `ldInfo` sources return one type -- the contract .loadLdFromIndexed states +# and the post-load chain (dedup / monomorphic / subsample) relies on. +# +# Not .ldDataFromMatrix(): that one is for a bare matrix with no metadata and +# substitutes placeholder chrNA:1..n coordinates. A precomputed LD block comes +# with its .bim/.pvar, so the real chrom/pos/alleles are carried through. +# @noRd +.ldDataFromProcessed <- function(proc) { + v <- proc$ldVariants + n <- nrow(v) + gr <- .refPanelToGranges(data.frame( + chrom = as.character(v$chrom), + pos = as.integer(v$pos), + variant_id = as.character(v$variants), + A1 = as.character(v$A1), + A2 = as.character(v$A2), + stringsAsFactors = FALSE + )) + LdData( + correlation = proc$ldMatrix, + variants = gr, + blockMetadata = tibble( + blockId = 1L, + size = n, + startIdx = 1L, + endIdx = n + ), + nRef = 0L + ) +} + +# Wrap a bare matrix as an LdData so every source returns one type. Variant +# identity comes from the dimnames when present. +# @noRd +.ldDataFromMatrix <- function(mat, isGenotype) { + ids <- if (isGenotype) colnames(mat) else rownames(mat) + n <- if (isGenotype) ncol(mat) else nrow(mat) + if (is.null(ids)) { + ids <- str_c("v", seq_len(n)) + } + gr <- GRanges( + seqnames = rep("chrNA", n), + ranges = IRanges::IRanges(start = seq_len(n), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(variant_id = ids) + LdData( + correlation = if (isGenotype) NULL else mat, + genotypeHandle = if (isGenotype) mat else NULL, + variants = gr, + blockMetadata = tibble(blockId = 1L, size = n), + nRef = if (isGenotype) nrow(mat) else 0L + ) +} + +# Drop variants with no variation. They carry no LD, and a zero-variance +# column makes a correlation undefined. +# @noRd +.ldApplyMonomorphic <- function(ld, dropMonomorphic) { + if (!isTRUE(dropMonomorphic)) { + return(ld) + } + refPanel <- getRefPanel(ld) + if (is.null(refPanel) || !is_in("allele_freq", colnames(refPanel))) { + return(ld) + } + p <- refPanel$allele_freq + keep <- !is.na(p) & p > 0 & p < 1 + if (all(keep)) { + return(ld) + } + .ldSubsetData(ld, which(keep)) +} + +# Randomly thin an oversized block, seeded per block so a run is reproducible +# without disturbing the session RNG. +# @noRd +.ldApplySubsample <- function(ld, maxVariants, seed, key) { + if (is.null(maxVariants) || length(ld) <= maxVariants) { + return(ld) + } + if (!is.null(seed)) { + offset <- if (is.numeric(key)) as.integer(key) else 0L + withr::local_seed(as.integer(seed) + offset) + } + .ldSubsetData(ld, sort(sample(length(ld), maxVariants))) +} + +# Read the dosages once and keep them on the object, so later access does no +# file I/O. +# @noRd +.ldApplyMaterialize <- function(ld, materializeGenotypes) { + if (!isTRUE(materializeGenotypes) || !hasGenotypes(ld)) { + return(ld) + } + X <- getGenotypes(ld) + if (!is.matrix(X)) { + return(ld) + } + LdData( + correlation = NULL, + genotypeHandle = X, + snpIdx = NULL, + variants = getVariantInfo(ld), + blockMetadata = getBlockMetadata(ld), + nRef = getNRef(ld) + ) +} + +# Narrow an LdData to a subset of its variants, keeping correlation and +# genotypes consistent with the ranges. +# @noRd +.ldSubsetData <- function(ld, idx) { + R <- ld@correlation + if (!is.null(R) && is.matrix(R)) { + R <- R[idx, idx, drop = FALSE] + } + gh <- ld@genotypeHandle + if (is.matrix(gh)) { + gh <- gh[, idx, drop = FALSE] + } else if (!is.null(ld@snpIdx)) { + ld@snpIdx <- ld@snpIdx[idx] + } + LdData( + correlation = R, + genotypeHandle = gh, + snpIdx = if (is.matrix(gh)) NULL else ld@snpIdx, + variants = getVariantInfo(ld)[idx], + blockMetadata = getBlockMetadata(ld), + nRef = getNRef(ld) + ) +} + +# @noRd +.loadLdFromMeta <- function( + ldMetaFilePath, + region, + extractCoordinates, + returnGenotype, + nSample ) { source <- resolveLdSource(ldMetaFilePath) isGeno <- is_in(source$type, c("plink2", "plink1", "vcf", "gds")) @@ -476,7 +770,7 @@ loadLdMatrix <- function( if (identical(returnGenotype, "auto")) { returnGenotype <- isGeno } - result <- .loadLdDispatch( + .loadLdDispatch( source, isGeno, region, @@ -484,7 +778,6 @@ loadLdMatrix <- function( returnGenotype, nSample ) - .loadLdDedup(result) } # ---------- Internal: resolve LD source type ---------- @@ -909,7 +1202,15 @@ loadLdFromGenotype <- function( # The panel's variant ranges: seqnames = chromosome (chr-prefixed), start = # position, mcols = SNP / A1 / A2. # @noRd -.ldSketchRanges <- function(x) { +.ldSketchRanges <- function(x, label = "LD sketch") { + # The chokepoint every panel accessor funnels through, so the guard lives + # here rather than being repeated at each entry point. Without it a NULL + # or non-panel sketch surfaces as "unable to find an inherited method for + # 'getSnpInfo'" from whichever accessor happened to touch it first, which + # says nothing about the LD reference being the problem. Callers that + # validate with their own label (`.ldFromSketch`, the ctwas assembler) do + # so first, so their message wins. + .ldFromSketchValidate(x, label) if (methods::is(x, "RangedSummarizedExperiment")) { return(SummarizedExperiment::rowRanges(x)) } @@ -985,6 +1286,8 @@ loadLdFromGenotype <- function( # layered on here rather than pushed down. # @noRd .ldSketchDosage <- function(x, snpIdx, meanImpute = TRUE) { + # The other primitive that does not pass through `.ldSketchRanges()`. + .ldFromSketchValidate(x, "LD sketch") if (!methods::is(x, "RangedSummarizedExperiment")) { return(.dosageMatrix(x, snpIdx, meanImpute = meanImpute)) } @@ -1034,7 +1337,11 @@ loadLdFromGenotype <- function( return(NULL) } o <- order(m$idxA) # restore the caller's requested order - list(keptIds = variantIds[m$idxA[o]], idx = m$idxB[o]) + list( + keptIds = variantIds[m$idxA[o]], + idx = m$idxB[o], + sign = m$sign[o] + ) } .ldFromSketch <- function( @@ -1054,6 +1361,16 @@ loadLdFromGenotype <- function( method = "sample", snpIdx = matched$idx ) + # The match above is allele-aware, so a panel entry whose alleles are + # swapped relative to the caller's id still matches -- but the dosage it + # returns counts the OTHER allele, which negates every correlation that + # variant takes part in (r(2 - x, y) = -r(x, y)). Put the matrix back in + # the caller's frame exactly as `.cbFlipPairToCanonical()` does: + # LD_ij -> sign_i * sign_j * LD_ij. A no-op on a harmonized panel, where + # every sign is +1. + if (any(matched$sign < 0)) { + ldMat <- ldMat * outer(matched$sign, matched$sign) + } dimnames(ldMat) <- list(matched$keptIds, matched$keptIds) if (onMissing == "drop") { attr(ldMat, "keptVariantIds") <- matched$keptIds @@ -1402,63 +1719,6 @@ standardizeGenotypeHwe <- function(X, alleleFreq) { sweep(Xstd, 2, sqrt(2 * alleleFreq * (1 - alleleFreq)), "/") } -#' Load LD sketch genotypes for a region -#' -#' Loads genotype data for a region via \code{loadLdMatrix(returnGenotype=TRUE)} -#' and removes monomorphic variants. Returns the raw genotype matrix and -#' metadata, which callers can use to derive either a correlation matrix R (for -#' summary-based weight training or fine-mapping) or an SVD (for TWAS z-score -#' computation). -#' -#' @param ldMetaFilePath Path to the LD metadata TSV file. -#' @param region Region of interest: "chr:start-end" string or data.frame with -#' chrom/start/end. -#' @param nSample Optional original panel sample size for computing variance (= -#' 2*p*(1-p)*n/(n-1)). Passed through to \code{loadLdMatrix()}. -#' -#' @return An \code{LdData} S4 object with monomorphic variants removed. -#' Consumers should use S4 accessors: \code{getGenotypes()}, -#' \code{getRefPanel()}, \code{getVariantIds()}. The number of sketch samples -#' is \code{nrow(getGenotypes(result))}. -#' @examples -#' meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", -#' package = "pecotmr") -#' loadLdSketch(ldMetaFilePath = meta, region = "chr22:16000000-18000000") -#' @export -loadLdSketch <- function(ldMetaFilePath, region, nSample = NULL) { - result <- loadLdMatrix( - ldMetaFilePath, - region, - returnGenotype = TRUE, - nSample = nSample - ) - if (!is(result, "LdData")) { - abort("loadLdMatrix must return an LdData object") - } - X <- getGenotypes(result) - refPanel <- getRefPanel(result) - - # Remove monomorphic variants (zero variance under HWE) - p <- refPanel$allele_freq - polymorphic <- p > 0 & p < 1 - if (!all(polymorphic)) { - X <- X[, polymorphic, drop = FALSE] - refPanel <- refPanel[polymorphic, , drop = FALSE] - } - - # Rebuild LdData with the extracted (and filtered) genotype matrix stored - # directly in genotypeHandle so getGenotypes() returns it without needing - # the original file handle. - variantsGr <- .refPanelToGranges(refPanel) - LdData( - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - variants = variantsGr, - blockMetadata = getBlockMetadata(result), - nRef = getNRef(result) - ) -} # ---------- Internal: load LD from pre-computed blocks ---------- @@ -1467,38 +1727,61 @@ loadLdSketch <- function(ldMetaFilePath, region, nSample = NULL) { #' @noRd # --- loadLdFromBlocks helpers ----------------------------------------------- -# Load + region-extract each LD block; track each block's chromosome. -.loadLdBlocksLoop <- function( +# One block's record: the region-extracted matrix, its variants, and the +# chromosome it sits on (falling back to the requested region's when the +# block contributed nothing). +# +# A RECORD rather than a position in three parallel lists: the filter and the +# metadata builder below would otherwise have to keep four sequences in the +# same order by hand, and a slip there would silently attach one block's +# chromosome to another block's variants. +# @noRd +.loadLdOneBlock <- function( + j, ldFilePaths, bimFilePaths, intersectedLdFiles, extractCoordinates ) { - matrices <- list() - variants <- list() - blockChroms <- character(length(ldFilePaths)) - for (j in seq_along(ldFilePaths)) { - proc <- processLdMatrix(ldFilePaths[j], bimFilePaths[j]) - extracted <- extractLdForRegion( - ldMatrix = proc$ldMatrix, - variants = proc$ldVariants, - region = intersectedLdFiles$region, - extractCoordinates = extractCoordinates - ) - matrices[[j]] <- extracted$extractedLdMatrix - variants[[j]] <- extracted$extractedLdVariants - blockChroms[j] <- if (nrow(variants[[j]]) > 0) { - as.character(variants[[j]]$chrom[1]) + proc <- processLdMatrix(ldFilePaths[[j]], bimFilePaths[[j]]) + extracted <- extractLdForRegion( + ldMatrix = proc$ldMatrix, + variants = proc$ldVariants, + region = intersectedLdFiles$region, + extractCoordinates = extractCoordinates + ) + blockVariants <- extracted$extractedLdVariants + list( + matrix = extracted$extractedLdMatrix, + variants = blockVariants, + chrom = if (nrow(blockVariants) > 0) { + as.character(blockVariants$chrom[[1L]]) } else { as.character(intersectedLdFiles$region$chrom) } - } - list(matrices = matrices, variants = variants, blockChroms = blockChroms) + ) +} + +# Load + region-extract each LD block, one record per block. +.loadLdBlocksLoop <- function( + ldFilePaths, + bimFilePaths, + intersectedLdFiles, + extractCoordinates +) { + map( + seq_along(ldFilePaths), + .loadLdOneBlock, + ldFilePaths = ldFilePaths, + bimFilePaths = bimFilePaths, + intersectedLdFiles = intersectedLdFiles, + extractCoordinates = extractCoordinates + ) } # Drop blocks with no variants in the region (error if none remain). -.loadLdFilterEmpty <- function(blocks, ldFilePaths) { - nonEmpty <- map_lgl(blocks$variants, .ldBlockHasVariants) +.loadLdFilterEmpty <- function(blocks) { + nonEmpty <- map_lgl(map(blocks, "variants"), .ldBlockHasVariants) if (!any(nonEmpty)) { abort("No variants found in any LD block for the specified region.") } @@ -1510,26 +1793,17 @@ loadLdSketch <- function(ldMetaFilePath, region, nSample = NULL) { ) inform(msg) } - list( - matrices = blocks$matrices[nonEmpty], - variants = blocks$variants[nonEmpty], - blockChroms = blocks$blockChroms[nonEmpty], - ldFilePaths = ldFilePaths[nonEmpty] - ) + blocks[nonEmpty] } # Per-block metadata (id, chrom, span, size, index range in the merged matrix). -.loadLdBlockMetadata <- function( - variants, - ldFilePaths, - blockChroms, - ldVariants -) { +.loadLdBlockMetadata <- function(blocks, ldVariants) { + variants <- map(blocks, "variants") blockVariants <- map(variants, "variants") blockPositions <- map(variants, "pos") tibble( - blockId = seq_along(ldFilePaths), - chrom = blockChroms, + blockId = seq_along(blocks), + chrom = map_chr(blocks, "chrom"), blockStart = map_dbl(blockPositions, min), blockEnd = map_dbl(blockPositions, max), size = map_int(blockVariants, length), @@ -1589,19 +1863,15 @@ loadLdFromBlocks <- function( intersectedLdFiles, extractCoordinates ) - filtered <- .loadLdFilterEmpty(blocks, ldFilePaths) + kept <- .loadLdFilterEmpty(blocks) + keptVariants <- map(kept, "variants") ldMatrix <- createLdMatrix( - ldMatrices = filtered$matrices, - variants = filtered$variants + ldMatrices = map(kept, "matrix"), + variants = keptVariants ) ldVariants <- rownames(ldMatrix) - blockMetadata <- .loadLdBlockMetadata( - filtered$variants, - filtered$ldFilePaths, - filtered$blockChroms, - ldVariants - ) - refPanel <- .loadLdRefPanel(ldMatrix, filtered$variants, nSample) + blockMetadata <- .loadLdBlockMetadata(kept, ldVariants) + refPanel <- .loadLdRefPanel(ldMatrix, keptVariants, nSample) variantsGr <- .refPanelToGranges(refPanel) LdData( correlation = ldMatrix, @@ -1827,9 +2097,6 @@ validateBlockStructure <- function(matrix, blockMetadata, variantIds) { # Exclude boundary variants (potential overlaps) vi <- variantIds[si:(ei - 1)] vj <- variantIds[(sj + 1):ej] - if (length(vi) == 0 || length(vj) == 0) { - return(character(0)) - } maxVal <- max(abs(matrix[vi, vj, drop = FALSE])) if (maxVal <= 1e-10) { return(character(0)) @@ -2185,13 +2452,11 @@ ldPruneByCorrelation <- function( !requireNamespace("SNPRelate", quietly = TRUE) || !requireNamespace("gdsfmt", quietly = TRUE) ) { - # nocov start msg <- glue( "Packages 'SNPRelate' and 'gdsfmt' are required for ", "backend='snprelate'." ) abort(msg) - # nocov end } } @@ -2253,11 +2518,11 @@ ldPruneByCorrelation <- function( #' @param strategy One of \code{"correlation"} (remove the column with the #' largest sum of absolute pairwise correlations among the candidates; when #' only two candidates, one is picked at random), \code{"variance"} (remove -#' the lowest-variance candidate), or \code{"response_correlation"} (remove +#' the lowest-variance candidate), or \code{"responseCorrelation"} (remove #' the candidate whose correlation with \code{response} has the smallest #' magnitude). #' @param response Numeric vector required when \code{strategy = -#' "response_correlation"}; the outcome to correlate against. +#' "responseCorrelation"}; the outcome to correlate against. #' @param verbose Logical. If TRUE, print which column was removed. Default #' FALSE. #' @@ -2331,7 +2596,7 @@ ldPruneByCorrelation <- function( if (is.null(response)) { msg <- glue( "response must be supplied for strategy = ", - "'response_correlation'" + "'responseCorrelation'" ) abort(msg) } @@ -2355,7 +2620,7 @@ ldPruneByCorrelation <- function( dropCollinearColumns <- function( X, problematicCols, - strategy = c("correlation", "variance", "response_correlation"), + strategy = c("correlation", "variance", "responseCorrelation"), response = NULL, verbose = FALSE, seed = NULL @@ -2536,7 +2801,7 @@ dropCollinearColumns <- function( #' Pass \code{NULL} or a zero-column matrix when there are no covariates. #' @param strategy Passed through to \code{dropCollinearColumns}. #' @param response Passed through to \code{dropCollinearColumns} when -#' \code{strategy = "response_correlation"}. +#' \code{strategy = "responseCorrelation"}. #' @param maxIterations Integer. Hard cap on the iterative-prune loop. Default #' 300. #' @param corrThresholds Numeric vector of |cor| thresholds used for the @@ -2566,7 +2831,7 @@ dropCollinearColumns <- function( enforceDesignFullRank <- function( X, C, - strategy = c("correlation", "variance", "response_correlation"), + strategy = c("correlation", "variance", "responseCorrelation"), response = NULL, maxIterations = 300L, corrThresholds = seq(0.75, 0.5, by = -0.05), @@ -2607,22 +2872,18 @@ enforceDesignFullRank <- function( # Require the bigsnpr/bigstatsr packages used for score-based LD clumping. .ldClumpCheckDeps <- function() { if (!requireNamespace("bigsnpr", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'bigsnpr' is required. Install from CRAN: ", "install.packages('bigsnpr')" ) abort(msg) - # nocov end } if (!requireNamespace("bigstatsr", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'bigstatsr' is required. Install from CRAN: ", "install.packages('bigstatsr')" ) abort(msg) - # nocov end } } @@ -2755,243 +3016,8 @@ extractLdMatrix <- function(ld, wantGenotype = FALSE) { getCorrelation(ld) } -# Validate an ldLoader spec: exactly one source + per-mode requirements. -.ldLoaderValidate <- function(rList, xList, ldMetaPath, regions, ldInfo) { - nSources <- sum( - !is.null(rList), - !is.null(xList), - !is.null(ldMetaPath), - !is.null(ldInfo) - ) - if (nSources != 1) { - abort("Provide exactly one of rList, xList, ldMetaPath, or ldInfo.") - } - if (!is.null(ldMetaPath) && is.null(regions)) { - abort("'regions' is required when using ldMetaPath.") - } - if ( - !is.null(ldInfo) && - (!is.data.frame(ldInfo) || !is_in("LD_file", colnames(ldInfo))) - ) { - abort("ldInfo must be a data.frame with column 'LD_file'.") - } -} - -#' Create an LD loader for on-demand block-wise LD retrieval -#' -#' Constructs a loader function that retrieves per-block LD matrices on demand. -#' This avoids loading all blocks into memory simultaneously, which is critical -#' for genome-wide analyses with hundreds of blocks. -#' -#' Four modes are supported: -#' -#' \describe{ -#' \item{list mode (R)}{Pre-loaded list of LD correlation matrices. -#' Simple but uses more memory. Set \code{R_list}.} -#' \item{list mode (X)}{Pre-loaded list of genotype matrices (n x p_g). -#' Set \code{X_list}.} -#' \item{region mode}{Loads LD from a pecotmr metadata TSV file on the fly -#' via \code{\link{loadLdMatrix}}. Memory-efficient for large datasets. -#' Set \code{ld_meta_path} and \code{regions}.} -#' \item{ldInfo mode}{Loads pre-computed LD blocks from \code{.cor.xz} -#' files listed in an \code{ldInfo} data.frame (as returned by -#' cTWAS meta-data utilities). Set \code{ldInfo}.} -#' } -#' -#' @param rList List of G precomputed LD correlation matrices (p_g x p_g). -#' @param xList List of G genotype matrices (n x p_g). -#' @param ldMetaPath Path to a pecotmr LD metadata TSV file (as used by -#' \code{\link{loadLdMatrix}}). -#' @param regions Character vector of G region strings (e.g., -#' \code{"chr22:17238266-19744294"}). Required when \code{ldMetaPath} is used. -#' @param ldInfo A data.frame with column \code{LD_file} (paths to genotype -#' files or \code{.cor.xz} LD matrix files) and optionally \code{SNP_file} -#' (paths to companion \code{.bim} files for pre-computed blocks; defaults to -#' \code{paste0(LD_file, ".bim")} if absent). Genotype paths can be PLINK2 -#' prefixes, PLINK1 prefixes, VCF files, or GDS files. As returned by cTWAS -#' meta-data utilities. -#' @param returnGenotype Logical. When using region mode, return the genotype -#' matrix X (\code{TRUE}) or LD correlation R (\code{FALSE}, default). -#' @param maxVariants Integer or \code{NULL}. If set, randomly subsample blocks -#' larger than this to control memory usage. -#' @param seed Integer or \code{NULL}. When \code{maxVariants} triggers -#' subsampling, seeds the draw (offset by the block index so each block is -#' independent yet reproducible) via a scoped \code{withr::local_seed}, so the -#' session RNG is left untouched. \code{NULL} (default) leaves the draw under -#' the session RNG, so an outer \code{set.seed()} still governs it. -#' -#' @return An \code{ldLoaderSpec} object (an opaque list describing the source). -#' Pass it with a block index to \code{\link{loadLdBlock}} to load one block. -#' -#' @seealso \code{\link{loadLdBlock}} -#' @examples -#' # List mode with pre-computed LD -#' R1 <- diag(10) -#' R2 <- diag(15) -#' spec <- ldLoader(rList = list(R1, R2)) -#' loadLdBlock(spec, 1) # returns R1 -#' loadLdBlock(spec, 2) # returns R2 -#' -#' @export -ldLoader <- function( - rList = NULL, - xList = NULL, - ldMetaPath = NULL, - regions = NULL, - ldInfo = NULL, - returnGenotype = FALSE, - maxVariants = NULL, - seed = NULL -) { - .ldLoaderValidate(rList, xList, ldMetaPath, regions, ldInfo) - mode <- if (!is.null(rList)) { - "rList" - } else if (!is.null(xList)) { - "xList" - } else if (!is.null(ldMetaPath)) { - "meta" - } else { - "info" - } - structure( - list( - mode = mode, - rList = rList, - xList = xList, - ldMetaPath = ldMetaPath, - regions = regions, - ldInfo = ldInfo, - returnGenotype = returnGenotype, - maxVariants = maxVariants, - seed = seed - ), - class = "ldLoaderSpec" - ) -} - - -# ---- Per-block loaders (one per ldLoader source mode) ----------------------- -# Top-level workers dispatched by .ldLoadBlock() on the spec's $mode; formerly -# branch closures inside ldLoader(). - -# @noRd -.ldLoadRList <- function(g, rList, maxVariants) { - R <- rList[[g]] - if (!is.null(maxVariants) && ncol(R) > maxVariants) { - keep <- sort(sample(ncol(R), maxVariants)) - R <- R[keep, keep] - } - R -} - -# @noRd -.ldLoadXList <- function(g, xList, maxVariants) { - X <- xList[[g]] - if (!is.null(maxVariants) && ncol(X) > maxVariants) { - keep <- sort(sample(ncol(X), maxVariants)) - X <- X[, keep] - } - X -} - -# @noRd -.ldLoadRegionMeta <- function( - g, - ldMetaPath, - regions, - returnGenotype, - maxVariants -) { - ld <- loadLdMatrix( - ldMetaPath, - region = regions[g], - returnGenotype = returnGenotype - ) - mat <- extractLdMatrix(ld, wantGenotype = returnGenotype) - if (!is.null(maxVariants) && ncol(mat) > maxVariants) { - keep <- sort(sample(ncol(mat), maxVariants)) - if (returnGenotype || nrow(mat) > ncol(mat)) { - mat <- mat[, keep] - } else { - mat <- mat[keep, keep] - } - } - # Center and scale genotype matrices - if (returnGenotype || nrow(mat) > ncol(mat)) { - mat <- scale(mat) - mat[is.na(mat)] <- 0 - } - mat -} - -# @noRd -.ldLoadIdInfo <- function(g, ldInfo, maxVariants) { - ldPath <- ldInfo$LD_file[g] - - # Auto-detect format: genotype source or pre-computed block - if (isGenotypeSource(ldPath)) { - geno <- loadGenotypeRegion(ldPath) - mat <- computeLd(geno) - } else { - # Pre-computed .cor.xz block - snpFile <- if (is_in("SNP_file", colnames(ldInfo))) { - ldInfo$SNP_file[g] - } else { - NULL # let processLdMatrix auto-detect .bim/.pvar/.pvar.zst - } - ld <- processLdMatrix(ldPath, snpFile) - mat <- extractLdMatrix(ld) - } - - if (!is.null(maxVariants) && ncol(mat) > maxVariants) { - keep <- sort(sample(ncol(mat), maxVariants)) - mat <- mat[keep, keep] - } - mat -} - -# Dispatch a single block load by the spec's source mode. -# @noRd -.ldLoadBlock <- function(spec, g) { - if (!is.null(spec$seed)) { - withr::local_seed(as.integer(spec$seed) + as.integer(g)) - } - switch( - spec$mode, - rList = .ldLoadRList(g, spec$rList, spec$maxVariants), - xList = .ldLoadXList(g, spec$xList, spec$maxVariants), - meta = .ldLoadRegionMeta( - g, - spec$ldMetaPath, - spec$regions, - spec$returnGenotype, - spec$maxVariants - ), - info = .ldLoadIdInfo(g, spec$ldInfo, spec$maxVariants) - ) -} - -#' Load one LD block from an ldLoader spec -#' -#' Given an \code{ldLoaderSpec} (from \code{\link{ldLoader}}) and a block index -#' \code{g}, load the corresponding LD correlation matrix (or the genotype -#' matrix, in region mode with \code{returnGenotype = TRUE}). -#' -#' @param spec An \code{ldLoaderSpec} object returned by \code{\link{ldLoader}}. -#' @param g Integer block index (1-based). -#' @return The LD correlation matrix or genotype matrix for block \code{g}. -#' @seealso \code{\link{ldLoader}} -#' @examples -#' spec <- ldLoader(rList = list(diag(10), diag(15))) -#' loadLdBlock(spec, 1) -#' @export -loadLdBlock <- function(spec, g) { - if (!inherits(spec, "ldLoaderSpec")) { - abort("`spec` must be an ldLoaderSpec (from ldLoader()).") - } - .ldLoadBlock(spec, g) -} +# ---- Per-block helpers ------------------------------------------------------ # ============================================================================= # LD correlation matrix from a dosage matrix @@ -3319,14 +3345,12 @@ computeLd <- function( #' @return Correlation matrix. #' @noRd .computeLdSnprelate <- function(X) { - # nocov start if (!requireNamespace("SNPRelate", quietly = TRUE)) { abort("Package 'SNPRelate' is required for backend='snprelate'") } if (!requireNamespace("gdsfmt", quietly = TRUE)) { abort("Package 'gdsfmt' is required for backend='snprelate'") } - # nocov end tmpGds <- tempfile(fileext = ".gds") on.exit(unlink(tmpGds), add = TRUE) @@ -3366,11 +3390,9 @@ computeLd <- function( #' @return Correlation matrix (r, not r^2). #' @noRd .computeLdSnpstats <- function(X) { - # nocov start if (!requireNamespace("snpStats", quietly = TRUE)) { abort("Package 'snpStats' is required for backend='snpstats'") } - # nocov end # snpStats expects counts of the B allele as raw codes: 1=AA, 2=AB, 3=BB, # 0=NA pecotmr dosage is ALT count (0/1/2), so map: 0->1, 1->2, 2->3, NA->0 diff --git a/R/manifestLoaders.R b/R/manifestLoaders.R index f1e04383..5f9330f7 100644 --- a/R/manifestLoaders.R +++ b/R/manifestLoaders.R @@ -377,10 +377,15 @@ NULL canonChrom(as.character(GenomicRanges::seqnames(sketchGr))), reqChrom ) + # Same matching relation `.ldFromSketch()` will use when the LD is + # actually loaded, palindromes included -- otherwise this counts an A/T + # variant as absent, under-reports the overlap and warns about a panel + # that will in fact match. nOverlap <- length( matchVariants( .grVariantIds(entryGr), - .grVariantIds(sketchGr[keep]) + .grVariantIds(sketchGr[keep]), + removeStrandAmbiguous = FALSE )$idxA ) if (nOverlap == 0L) { diff --git a/R/mashPipeline.R b/R/mashPipeline.R index b1b08a95..2bcff321 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -7,19 +7,44 @@ #' @param sumStatsList Named list (or \code{SimpleList}) of #' \code{\link{QtlSumStats}} or \code{\link{GwasSumStats}} objects. Required #' names: \code{"strong"} (discovery variants), \code{"random"} (random -#' background). Optional: \code{"null"} (for residual correlation estimation). +#' background, the partition the mixture weights are fit on). Optional: +#' \code{"null"} (null variants), needed only by the +#' \code{residualCorrelationMethod} values that estimate \eqn{\hat V} from +#' them. #' @param alpha Numeric (length 1). Variance-stabilising-transform exponent #' forwarded to \code{mashr::mash_set_data()}. Use \code{alpha = 0} on the #' BETA scale, \code{alpha = 1} on the Z scale. #' @param residualCorrelation Optional pre-computed residual correlation matrix -#' (\code{Vhat}). When supplied, replaces the inline -#' \code{mashr::estimate_null_correlation_simple()} call entirely and the -#' \code{"random"} slot of \code{sumStatsList} becomes optional (the function -#' does not need it for anything else). Useful when \code{Vhat} was estimated -#' previously on a larger reference and shipped as a static artefact (the -#' legacy MWE pattern). +#' (\code{Vhat}). When supplied, it is used as-is: +#' \code{residualCorrelationMethod} is not consulted, and the +#' \code{"random"} slot of \code{sumStatsList} becomes optional (the +#' function does not need it for anything else). Useful when \code{Vhat} was +#' estimated previously on a larger reference and shipped as a static +#' artefact (the legacy MWE pattern). +#' @param residualCorrelationMethod How to estimate \eqn{\hat V} when +#' \code{residualCorrelation} is not supplied; forwarded to +#' \code{\link{mashResidualCorrelation}}, which is where each estimator is +#' described. +#' +#' \code{"identity"} (the default) takes the residual correlation to be the +#' identity, needs no extra partition, and never depends on which partitions +#' were supplied. It is the safe default rather than the best one: it +#' assumes conditions share no residual correlation, which +#' overlapping-sample designs -- the usual multi-context QTL case, where the +#' same donors are measured in every context -- violate. Supplying a +#' \code{"null"} partition while leaving this at \code{"identity"} reports +#' that the partition is unused, since that combination is more often an +#' oversight than an intent. +#' +#' The estimators differ in what they require: \code{"simple"}, +#' \code{"simpleSpecific"} and \code{"corshrink"} need a \code{"null"} +#' entry; \code{"mle"} needs \code{"random"} plus a supplied +#' \code{priorCovariances} to refine against. A named method whose +#' requirement is unmet is a hard error, not a silent fallback. #' @param priorCovariances Optional named list of square covariance matrices -#' (the \code{Ulist} \code{mashr::mash()} consumes). When supplied, replaces +#' (the \code{Ulist} \code{mashr::mash()} consumes), or a +#' \code{\link{mashPriorCovariances}} result, which is unwrapped to its +#' \code{U}. When supplied, replaces #' the canonical + PCA + flash + ED chain (\code{cov_canonical} / #' \code{cov_pca} / \code{cov_flash} / \code{cov_ed}) entirely; mash sees only #' the supplied matrices. Every entry must be a \code{ncol(Bhat) x ncol(Bhat)} @@ -57,12 +82,20 @@ mashPipeline <- function( sumStatsList, alpha, residualCorrelation = NULL, + residualCorrelationMethod = c( + "identity", + "simple", + "simpleSpecific", + "corshrink", + "mle" + ), priorCovariances = NULL, nPcs = NULL, inputScale = c("auto", "beta", "z"), setSeed = 999 ) { inputScale <- arg_match(inputScale) + residualCorrelationMethod <- arg_match(residualCorrelationMethod) .mashRequirePriorPackages() # Accept either a base list or a S4Vectors::SimpleList. if (methods::is(sumStatsList, "SimpleList")) { @@ -74,7 +107,9 @@ mashPipeline <- function( sumStatsList, alpha, inputScale, - residualCorrelation + residualCorrelation, + residualCorrelationMethod, + priorCovariances ) # mashPriorCovariances() owns the cov_* chain, the supplied-prior bypass, # and the mash() weight fit; mashPipeline just forwards its arguments. @@ -128,8 +163,52 @@ mashPipeline <- function( } } -# Vhat: the supplied residualCorrelation, else estimate it via -# mashResidualCorrelation ('simple' when a null set exists, else 'identity'). +# Identity ignores the null partition entirely, so a caller who assembled one +# and still landed on identity has gone to real trouble for nothing -- most +# likely they expected the null set to be used. Say so rather than quietly +# discarding it. Identity assumes conditions share no residual correlation, +# which overlapping-sample designs (the usual multi-context QTL case, where +# the same donors appear in every context) violate. +# @noRd +.mashNoteUnusedNull <- function(method, sumStatsList) { + hasNull <- is_in("null", names(sumStatsList)) && !is.null(sumStatsList$null) + if (method != "identity" || !hasNull) { + return(invisible(FALSE)) + } + inform(glue( + "mashPipeline: `sumStatsList` carries a 'null' partition, but ", + "residualCorrelationMethod = 'identity' does not use it -- the ", + "residual correlation is taken to be the identity. Pass ", + "'simple' (or 'simpleSpecific' / 'corshrink') to estimate it from ", + "those null variants instead." + )) + invisible(TRUE) +} + +# A prior covariance list reaches the consumers in one of two shapes, because +# the two producers disagree: mashCovarianceComponents() returns a bare Ulist +# (a named list of matrices) while mashPriorCovariances() wraps it as +# list(U, w, loglik). Accept either, so the output of either producer can be +# handed straight to any consumer. A real Ulist entry named "U" would be a +# matrix rather than a list, so the two shapes cannot be confused. +# @noRd +.mashAsUlist <- function(priorCovariances) { + isWrapped <- is.list(priorCovariances) && + is_in("U", names(priorCovariances)) && + is.list(priorCovariances$U) && + !is.matrix(priorCovariances$U) + if (isWrapped) { + return(priorCovariances$U) + } + priorCovariances +} + +# Vhat: the supplied residualCorrelation, else whatever +# `residualCorrelationMethod` names. The method used to be inferred from the +# partitions present ('simple' when a null set existed, else 'identity'), +# which meant a caller without a null set silently assumed zero residual +# correlation between conditions -- a statistical choice, made invisibly. +# It is now always the caller's, named up front. # setSeed = NULL leaves the RNG stream (seeded by the caller) untouched, so # delegated calls consume it in the original order. # @noRd @@ -137,16 +216,19 @@ mashPipeline <- function( sumStatsList, alpha, inputScale, - residualCorrelation + residualCorrelation, + method, + priorCovariances ) { if (!is.null(residualCorrelation)) { return(residualCorrelation) } - hasNull <- is_in("null", names(sumStatsList)) && !is.null(sumStatsList$null) + .mashNoteUnusedNull(method, sumStatsList) mashResidualCorrelation( sumStatsList, alpha, - method = if (hasNull) "simple" else "identity", + method = method, + priorCovariances = priorCovariances, inputScale = inputScale, setSeed = NULL ) @@ -166,13 +248,15 @@ mashPipeline <- function( #' @param method Estimator, all on the \code{"null"} partition unless noted. #' \code{"simple"} = mashr \code{estimate_null_correlation_simple()}; #' \code{"identity"} = \code{diag(nConditions)} (reads only \code{"strong"}); -#' \code{"simple_specific"} = \code{Matrix::nearPD(cov(nullZ), corr = TRUE)}; +#' \code{"simpleSpecific"} = \code{Matrix::nearPD(cov(nullZ), corr = TRUE)}; #' \code{"corshrink"} = \code{CorShrink::CorShrinkData()} adaptive-shrinkage #' correlation (needs the \pkg{CorShrink} package); \code{"mle"} = #' \code{mashr::mash_estimate_corr_em()} on a random subset (needs #' \code{"random"} + \code{priorCovariances}). #' @param priorCovariances Prior \code{U} list (required by \code{method = -#' "mle"}). +#' "mle"}). Accepts a bare named list of covariance matrices or a +#' \code{\link{mashPriorCovariances}} result, which is unwrapped to its +#' \code{U}. #' @param nSubset,maxIter \code{method = "mle"} controls (random-subset size and #' EM iterations). #' @param inputScale SumStats -> matrix conversion scale (\code{"auto"} / @@ -191,7 +275,7 @@ mashPipeline <- function( mashResidualCorrelation <- function( sumStatsList, alpha, - method = c("simple", "identity", "mle", "corshrink", "simple_specific"), + method = c("simple", "identity", "mle", "corshrink", "simpleSpecific"), priorCovariances = NULL, nSubset = 6000L, maxIter = 6L, @@ -201,13 +285,11 @@ mashResidualCorrelation <- function( method <- arg_match(method) inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install mashr: ", "https://cran.r-project.org/web/packages/mashr/index.html" ) abort(msg) - # nocov end } if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) @@ -289,6 +371,7 @@ mashResidualCorrelation <- function( ) abort(msg) } + priorCovariances <- .mashAsUlist(priorCovariances) randomMats <- .mashSumStatsToMatrices( sumStatsList$random, "random", @@ -311,7 +394,7 @@ mashResidualCorrelation <- function( fit$V } -# methods 'corshrink' / 'simple_specific': estimate V on the null z-matrix. The +# methods 'corshrink' / 'simpleSpecific': estimate V on the null z-matrix. The # `null` partition is already the null variants (max|z| < 2), so no # re-thresholding is needed. # @noRd @@ -329,7 +412,7 @@ mashResidualCorrelation <- function( inputScale = inputScale ) nullZ <- nullMats$b / nullMats$s - if (method == "simple_specific") { + if (method == "simpleSpecific") { return(as.matrix( Matrix::nearPD( stats::cov(nullZ), @@ -340,13 +423,11 @@ mashResidualCorrelation <- function( )) } if (!requireNamespace("CorShrink", quietly = TRUE)) { - # nocov start msg <- glue( "mashResidualCorrelation: method 'corshrink' needs the CorShrink ", - "package. Install it, or use 'simple' / 'simple_specific'." + "package. Install it, or use 'simple' / 'simpleSpecific'." ) abort(msg) - # nocov end } as.matrix( CorShrink::CorShrinkData( @@ -358,7 +439,7 @@ mashResidualCorrelation <- function( } # Internal: build the requested data-driven covariance components off a prepared -# mashr data object, in a fixed order (canonical, pca, flash, flash_nonneg) so a +# mashr data object, in a fixed order (canonical, pca, flash, flashNonneg) so a # given `components` set reproduces the same ordering everywhere. RNG is # consumed only by cov_flash / cov_flash(nonneg). Shared by mashPriorCovariances # and the exported mashCovarianceComponents. @@ -377,7 +458,7 @@ mashResidualCorrelation <- function( if (is_in("flash", components)) { comps <- c(comps, mashr::cov_flash(mashData)) } - if (is_in("flash_nonneg", components)) { + if (is_in("flashNonneg", components)) { comps <- c(comps, mashr::cov_flash(mashData, factors = "nonneg")) } comps @@ -396,7 +477,7 @@ mashResidualCorrelation <- function( #' @param alpha mash \code{alpha}. #' @param vhat Residual correlation matrix (\code{V}); \code{NULL} -> identity. #' @param components Any of \code{"canonical"}, \code{"pca"}, \code{"flash"}, -#' \code{"flash_nonneg"}. Built in that fixed order. +#' \code{"flashNonneg"}. Built in that fixed order. #' @param nPcs PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}. #' @param inputScale SumStats -> matrix conversion scale. #' @param setSeed Integer seed (\code{cov_flash} is stochastic), or \code{NULL} @@ -413,7 +494,7 @@ mashCovarianceComponents <- function( sumStatsList, alpha, vhat = NULL, - components = c("canonical", "pca", "flash", "flash_nonneg"), + components = c("canonical", "pca", "flash", "flashNonneg"), nPcs = NULL, inputScale = c("auto", "beta", "z"), setSeed = 999 @@ -443,7 +524,7 @@ mashCovarianceComponents <- function( #' collection. Split out of \code{\link{mashPipeline}} so the #' covariance-estimation chain lives in one place. The default builds every #' non-udr covariance component (\code{canonical + pca + flash + -#' flash_nonneg}) and refines them with mashr extreme deconvolution +#' flashNonneg}) and refines them with mashr extreme deconvolution #' (\code{cov_ed}). #' @param sumStatsList Named list (or \code{S4Vectors::SimpleList}) with at #' least \code{"strong"} (the discovery set the covariances are learned on). @@ -452,7 +533,7 @@ mashCovarianceComponents <- function( #' \code{\link{mashResidualCorrelation}}. \code{NULL} -> identity. #' @param components Data-driven covariance components, any of #' \code{"canonical"}, \code{"pca"}, \code{"flash"} (default -#' \code{cov_flash}), \code{"flash_nonneg"} (\code{cov_flash(factors = +#' \code{cov_flash}), \code{"flashNonneg"} (\code{cov_flash(factors = #' "nonneg")}). Built in that fixed order. Ignored by the \code{"ud"} / #' \code{"ud_ted"} engines. #' @param engine Covariance-refinement engine. \code{"cov_ed"} (default; mashr's @@ -463,11 +544,15 @@ mashCovarianceComponents <- function( #' not the default; \code{"ud_ted"} additionally needs i.i.d. (z-scale) data). #' @param nPcs PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}. #' @param priorCovariances Optional caller-supplied prior \code{U}: a non-empty -#' named list of \code{nCond x nCond} matrices. When supplied, the covariance -#' chain is bypassed and only the mixture-weight fit runs. +#' named list of \code{nCond x nCond} matrices, or a +#' \code{\link{mashPriorCovariances}} result, which is unwrapped to its +#' \code{U}. When supplied, the covariance chain is bypassed and only the +#' mixture-weight fit runs. #' @param priorComponents Optional caller-supplied raw covariance components (a #' non-empty named list, e.g. the concatenated -#' \code{\link{mashCovarianceComponents}} outputs). When supplied, these are +#' \code{\link{mashCovarianceComponents}} outputs, or a +#' \code{\link{mashPriorCovariances}} result, which is unwrapped to its +#' \code{U}). When supplied, these are #' refined by \code{engine} instead of being rebuilt internally -- the #' mixture-prior pipeline where separate steps built the components. #' \code{components} / \code{nPcs} are then ignored. Distinct from @@ -494,7 +579,7 @@ mashPriorCovariances <- function( sumStatsList, alpha, vhat = NULL, - components = c("canonical", "pca", "flash", "flash_nonneg"), + components = c("canonical", "pca", "flash", "flashNonneg"), engine = c("cov_ed", "ud", "ud_ted"), nPcs = NULL, priorCovariances = NULL, @@ -545,7 +630,7 @@ mashPriorCovariances <- function( components, caller = "mashPriorCovariances" ) { - valid <- c("canonical", "pca", "flash", "flash_nonneg") + valid <- c("canonical", "pca", "flash", "flashNonneg") bad <- setdiff(as.character(components), valid) if (length(bad) > 0L) { msg <- glue( @@ -561,22 +646,18 @@ mashPriorCovariances <- function( # @noRd .mashRequirePriorPackages <- function() { if (!requireNamespace("mashr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install mashr: ", "https://cran.r-project.org/web/packages/mashr/index.html" ) abort(msg) - # nocov end } if (!requireNamespace("flashier", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install flashier: ", "https://github.com/willwerscheid/flashier" ) abort(msg) - # nocov end } } @@ -601,6 +682,7 @@ mashPriorCovariances <- function( # matrices. Returns list(U, w = NULL, loglik = NULL). # @noRd .mashUserPriorCovariances <- function(priorCovariances, mashData) { + priorCovariances <- .mashAsUlist(priorCovariances) if ( !is.list(priorCovariances) || length(priorCovariances) == 0L || @@ -659,6 +741,7 @@ mashPriorCovariances <- function( components, nPcs ) { + priorComponents <- .mashAsUlist(priorComponents) if (is.null(priorComponents)) { return(.mashBuildComponents( mashData, @@ -739,13 +822,11 @@ mashPriorCovariances <- function( # @noRd .mashEngineUd <- function(mashData, engine, udControl) { if (!requireNamespace("udr", quietly = TRUE)) { - # nocov start msg <- glue( "mashPriorCovariances: engine '{engine}' needs the udr package. ", "Install it, or use the default 'cov_ed'." ) abort(msg) - # nocov end } udControl <- utils::modifyList( list( @@ -782,8 +863,11 @@ mashPriorCovariances <- function( #' \code{\link{QtlSumStats}} / \code{\link{GwasSumStats}}; must contain the #' \code{fitOn} entry. #' @param alpha mash \code{alpha} (forwarded to \code{mashr::mash_set_data()}). -#' @param priorCovariances The prior covariance list (\code{U}) to fit with -- -#' e.g. the \code{$U} of a \code{\link{mashPriorCovariances}} result. +#' @param priorCovariances The prior covariance list (\code{U}) to fit with. +#' Either shape the producers return is accepted: a bare named list of +#' covariance matrices (\code{\link{mashCovarianceComponents}}) or the +#' \code{list(U, w, loglik)} a \code{\link{mashPriorCovariances}} result +#' carries, which is unwrapped to its \code{U}. #' @param vhat Residual correlation matrix (\code{V}); \code{NULL} -> identity. #' @param fitOn Partition to learn the mixture weights on: \code{"random"} #' (default, the standard unbiased choice) or \code{"strong"}. @@ -808,7 +892,7 @@ mashPriorCovariances <- function( #' dimnames(vhat) <- list(conds, conds) #' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, #' components = "canonical") -#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, #' vhat = vhat) #' @export mashModelFit <- function( @@ -824,17 +908,16 @@ mashModelFit <- function( fitOn <- arg_match(fitOn) inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install mashr: ", "https://cran.r-project.org/web/packages/mashr/index.html" ) abort(msg) - # nocov end } if (methods::is(sumStatsList, "SimpleList")) { sumStatsList <- as.list(sumStatsList) } + priorCovariances <- .mashAsUlist(priorCovariances) .mashValidatePriorCovList(priorCovariances) if (is.null(sumStatsList[[fitOn]])) { msg <- glue( @@ -911,7 +994,7 @@ mashModelFit <- function( #' dimnames(vhat) <- list(conds, conds) #' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, #' components = "canonical") -#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, #' vhat = vhat) #' mashPosterior(model, mk("strong.b", "strong.s"), alpha = 0, vhat = vhat) #' @export @@ -926,13 +1009,11 @@ mashPosterior <- function( ) { inputScale <- arg_match(inputScale) if (!requireNamespace("mashr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install mashr: ", "https://cran.r-project.org/web/packages/mashr/index.html" ) abort(msg) - # nocov end } mats <- .mashSumStatsToMatrices(sumStats, "target", inputScale = inputScale) ex <- .mashExcludeConditions( @@ -1274,7 +1355,7 @@ mashPosteriorContrast <- function( #' dimnames(vhat) <- list(conds, conds) #' prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, #' components = "canonical") -#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +#' model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, #' vhat = vhat) #' updateMashModelCov(model, allSamples = conds, samples = conds[1:3]) #' @export diff --git a/R/mashWrapper.R b/R/mashWrapper.R index f4570463..9fe94e81 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -1227,7 +1227,7 @@ qtlSumStatsFromBetaMatrix <- function( # @noRd .mashRowDf <- function(x, rIdx, setup, requireCols) { if (setup$isQtl) { - getSumstatDf( + getSumStatsDf( x, study = setup$studyCol[[rIdx]], context = setup$contextCol[[rIdx]], @@ -1235,7 +1235,7 @@ qtlSumStatsFromBetaMatrix <- function( require = requireCols ) } else { - getSumstatDf(x, study = setup$studyCol[[rIdx]], require = requireCols) + getSumStatsDf(x, study = setup$studyCol[[rIdx]], require = requireCols) } } @@ -1347,7 +1347,7 @@ qtlSumStatsFromBetaMatrix <- function( .mashAsDataFrameOrNull <- function(m) { if (is.null(m)) { return(NULL) - } # nocov (partitions are always matrices here, never NULL) + } as.data.frame(m) } diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R index 2fbf8c27..247fffb2 100644 --- a/R/overlapTopLoci.R +++ b/R/overlapTopLoci.R @@ -108,12 +108,10 @@ setMethod( if (is.null(vmap)) { return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols, type)) } + # No zero-row check on `g`: every gwas_vid in `vmap` is drawn from + # gwasTl$variant_id, so once vmap is non-NULL the inner join above + # always matches. The no-overlap case is the is.null(vmap) return. g <- .overlapRelabelGwas(gwasTl, vmap, coordCols) - if (nrow(g) == 0L) { - # nocov start - return(.overlapEmptyReturn(qtlTl, gwasTl, coordCols, keyCols, type)) - # nocov end - } # Wide cross-product per shared variant, variant key kept once (QTL). merged <- inner_join( .overlapPrefixNonKey(qtlTl, "qtl_", keyCols), diff --git a/R/pvalCombine.R b/R/pvalCombine.R index 46ec596b..14fc0df0 100644 --- a/R/pvalCombine.R +++ b/R/pvalCombine.R @@ -89,13 +89,11 @@ pvalAcat <- function(pvals, naRm = TRUE) { pvalHmp <- function(pvals) { # Make sure harmonicmeanp is installed if (!requireNamespace("harmonicmeanp", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install harmonicmeanp: ", "https://cran.r-project.org/web/packages/harmonicmeanp/index.html" ) abort(msg) - # nocov end } # https://search.r-project.org/CRAN/refmans/harmonicmeanp/html/pLandau.html L <- length(pvals) @@ -122,13 +120,11 @@ pvalHmp <- function(pvals) { pvalPoolr <- function(pvals, method, R) { if (!requireNamespace("poolr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this method, please install poolr: ", "install.packages('poolr')" ) abort(msg) - # nocov end } fn <- switch( method, @@ -142,9 +138,7 @@ pvalPoolr <- function(pvals, method, R) { pvalGbj <- function(zScores, R, method) { if (!requireNamespace("GBJ", quietly = TRUE)) { - # nocov start abort("To use this method, please install GBJ: install.packages('GBJ')") - # nocov end } result <- switch( method, @@ -170,11 +164,9 @@ pvalGbj <- function(zScores, R, method) { pvalAspu <- function(zScores = NULL, pvals = NULL, R, method) { if (!requireNamespace("aSPU", quietly = TRUE)) { - # nocov start abort( "To use this method, please install aSPU: install.packages('aSPU')" ) - # nocov end } switch( method, diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R index db9778f6..21bd39d4 100644 --- a/R/qtlAssociationPostprocess.R +++ b/R/qtlAssociationPostprocess.R @@ -25,13 +25,12 @@ # Returns a numeric vector aligned to `p`. .qapSafeQvalue <- function(p) { if (!requireNamespace("qvalue", quietly = TRUE)) { - # nocov start (optional-package guard; qvalue is Suggests-only) + # Optional-package guard; qvalue is Suggests-only. msg <- glue( "qtlAssociationPostprocess: the 'qvalue' package is required for ", "Storey q-values. Install Bioconductor 'qvalue'." ) abort(msg) - # nocov end } tryCatch( qvalue::qvalue(p)$qvalues, diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index 488c4974..a962b5f0 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -80,9 +80,7 @@ setClass( # qcInfo slot must be a list. # @noRd .qssCheckQcInfo <- function(object) { - if (!is.list(object@qcInfo)) { - return("'qcInfo' slot must be a list") - } + # The slot's declared type enforces this; nothing to check. NULL } @@ -390,8 +388,9 @@ QtlSumStats <- function( #' enriched by \code{\link{qtlAssociationPostprocess}}, a logical #' \code{significant} mcol for that method is added to the returned entry (the #' significance is derived on the fly, not stored). Flat export flattens this -#' full entry GRanges (all mcols) directly; note \code{\link{getSumstatDf}} is -#' a fixed GWAS-schema view and does not carry the association columns. +#' full entry GRanges (all mcols) directly; note +#' \code{\link{getSumStatsDf}} is a fixed GWAS-schema view and does not +#' carry the association columns. #' @export setMethod( "getSumStats", @@ -429,10 +428,10 @@ setMethod( # getZ / getN / getMaf / nSnps are provided once by SumStatsBase (AllClasses.R); # they only delegate to getSumStats(). -#' @rdname getSumstatDf +#' @rdname getSumStatsDf #' @export setMethod( - "getSumstatDf", + "getSumStatsDf", "QtlSumStats", function( x, @@ -547,17 +546,19 @@ setMethod("show", "QtlSumStats", function(object) { if (length(gr) == 0L) { return(gr) } + # `traitPos[i]` is a length-1 GRanges (an out-of-range `i` errors here + # rather than yielding an empty one), and a GRanges cannot carry an NA + # start, so the position is always real. tp <- traitPos[i] tssPos <- GenomicRanges::start(tp) tesPos <- GenomicRanges::end(tp) - if (length(tssPos) == 0L || is.na(tssPos)) { - return(gr) - } pos <- GenomicRanges::start(gr) + # No zero-column swap: mcols() on a GRanges is never NULL, and a variant + # set with no metadata yields a zero-COLUMN DataFrame that already carries + # one row per variant. Replacing it with DataFrame(row.names = NULL) threw + # that row count away, so the assignment below died with "n elements in + # value to replace 0 elements" for any entry without mcols. mc <- S4Vectors::mcols(gr) - if (is.null(mc) || ncol(mc) == 0L) { - mc <- S4Vectors::DataFrame(row.names = NULL) - } if (is.null(mc[["tss_distance"]])) { mc[["tss_distance"]] <- pos - tssPos } diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 8ae5681f..39dbdd03 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -23,10 +23,10 @@ #' }) #' stat <- list(b = vapply(ss, `[`, numeric(1), 1L), #' seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) -#' mrAshRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), +#' mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), #' s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) #' @export -mrAshRssWeights <- function( +mrashRssWeights <- function( stat, LD, varY, @@ -229,8 +229,9 @@ prsCsWeights <- function(stat, LD, ...) { #' #' @param seed Integer or \code{NULL}. Random seed for the Gibbs sampler; #' \code{NULL} leaves the RNG state unchanged. -#' @return A list containing the estimated effect sizes (beta) and heritability -#' (h2). +#' @return A list with \code{betaEst} (the estimated effect sizes) and +#' \code{h2} (the estimated heritability). \code{sdprWeights()} returns +#' only \code{betaEst}; call this directly when you also want \code{h2}. #' @examples #' # Generate example data #' set.seed(985115) @@ -272,10 +273,11 @@ prsCsWeights <- function(stat, LD, ...) { #' # In sample prediction correlations #' cor(X %*% out$betaEst, y) # #' -#' @note This function is a wrapper for the SDPR C++ implementation, which is a -#' rewritten and adopted version -#' of the SDPR package. The original SDPR documentation is available at -#' https://htmlpreview.github.io/?https://github.com/eldronzhou/SDPR/blob/main/doc/Manual.html +#' @note This function wraps a rewritten and adapted version of the SDPR C++ +#' implementation. SDPR is described in Zhou G, Zhao H (2021), "A fast and +#' robust Bayesian nonparametric method for prediction of complex traits +#' using summary statistics", PLoS Genetics 17(7): e1009697. +#' \doi{10.1371/journal.pgen.1009697} #' #' @export sdpr <- function( @@ -409,13 +411,11 @@ mrmashWeights <- function( ... ) { if (!requireNamespace("mr.mashr", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'mr.mashr' is required. Install with: ", "devtools::install_github('stephenslab/mr.mashr')" ) abort(msg) - # nocov end } dotArgs <- list(...) if (is.null(mrmashFit)) { @@ -575,14 +575,12 @@ mrmashRssWeights <- function( # @noRd .mrmashRssRequirePackage <- function() { if (!requireNamespace("mr.mashr", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'mr.mashr' is required. ", "Install with: ", "devtools::install_github('stephenslab/mr.mash.alpha')" ) abort(msg) - # nocov end } } @@ -593,7 +591,7 @@ mrmashRssWeights <- function( if (ncol(Z) < 2) { msg <- glue( "mrmashRssWeights expects stat$z to have >= 2 columns ", - "(one per context). For single-context use mrAshRssWeights()." + "(one per context). For single-context use mrashRssWeights()." ) abort(msg) } @@ -713,13 +711,11 @@ initPriorSd <- function(X, y, n = 30) { glmnetWeights <- function(X, y, alpha) { # Check if glmnet is installed if (!requireNamespace("glmnet", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install glmnet: ", "https://cran.r-project.org/web/packages/glmnet/index.html" ) abort(msg) - # nocov end } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "glmnetWeights") @@ -796,7 +792,7 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { } else if (length(argsList$beta.init) == ncol(X)) { argsList$beta.init <- argsList$beta.init[keep] } - mrAshArgs <- c( + mrashArgs <- c( list( X = XKeep, y = y, @@ -804,7 +800,7 @@ mrashWeights <- function(X, y, initPriorSd = TRUE, retainFit = FALSE, ...) { ), argsList ) - fit.mr.ash <- exec(mr.ash, !!!mrAshArgs) + fit.mr.ash <- exec(mr.ash, !!!mrashArgs) eff.wgt[keep] <- predict(fit.mr.ash, type = "coefficients")[-1] if (retainFit) { attr(eff.wgt, "fit") <- fit.mr.ash @@ -881,13 +877,11 @@ bayesAlphabetWeights <- function( # @noRd .bayesAlphabetValidate <- function(X, y, Z) { if (!requireNamespace("qgg", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install qgg: ", "https://cran.r-project.org/web/packages/qgg/index.html" ) abort(msg) - # nocov end } if (!(length(y) == nrow(X))) { abort("All objects must have the same number of rows") @@ -1513,7 +1507,7 @@ lassosumRss <- function( list( beta = candidateBeta[, idx], index = idx, - mode = "min_fbeta" + mode = "minFbeta" ) } @@ -1528,7 +1522,7 @@ lassosumRss <- function( list( beta = candidateBeta[, idx], index = idx, - mode = "ld_quadratic" + mode = "ldQuadratic" ) } @@ -1684,7 +1678,7 @@ lassosumRss <- function( # Shared scaffold for the RSS shrinkage-grid weight functions # (lassosumRssWeights / .penalizedRssWeights / l0learnRssWeights). Standardizes # the stat -> solverInput conversion, the outer LD-shrinkage grid over `s`, the -# candidate accumulation, and the ld_quadratic / min_fbeta selection. `method` + +# candidate accumulation, and the ldQuadratic / minFbeta selection. `method` + # `config` pick the per-`s` solver (.rssFitOne) and the finalizer # (.rssFinalize). .rssShrinkGridWeights <- function( @@ -1693,7 +1687,7 @@ lassosumRss <- function( s, method, config, - selection = c("ld_quadratic", "min_fbeta") + selection = c("ldQuadratic", "minFbeta") ) { selection <- arg_match(selection) n <- median(stat$n) @@ -1709,7 +1703,7 @@ lassosumRss <- function( candidateMeta[[length(candidateMeta) + 1L]] <- one$meta } candidateMeta <- bind_rows(candidateMeta) - selectorResult <- if (selection == "ld_quadratic") { + selectorResult <- if (selection == "ldQuadratic") { .lassosumSelectLdQuadratic(candidateBeta, corInput, LD) } else { .lassosumSelectMinFbeta(candidateBeta, candidateMeta) @@ -1743,9 +1737,9 @@ lassosumRss <- function( #' @param LD LD correlation matrix R (single matrix, NOT pre-shrunk). #' @param s Numeric vector of shrinkage parameters to search over. Default: #' \code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS. -#' @param selection Selection strategy. Default \code{"ld_quadratic"} uses +#' @param selection Selection strategy. Default \code{"ldQuadratic"} uses #' \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. -#' \code{"min_fbeta"} is retained as an explicit alternative for debugging. +#' \code{"minFbeta"} is retained as an explicit alternative for debugging. #' @param ... Additional arguments passed to \code{lassosumRss()}. #' #' @return A numeric vector of the posterior SNP coefficients at the best (s, @@ -1768,7 +1762,7 @@ lassosumRssWeights <- function( stat, LD, s = c(0.2, 0.5, 0.9, 1.0), - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) { selection <- arg_match(selection) @@ -1897,7 +1891,7 @@ penalizedRss <- function( alpha = 1.0, lambda0 = 0, lambda2 = 0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) { selection <- arg_match(selection) @@ -1931,8 +1925,8 @@ penalizedRss <- function( #' 0.5, 0.9, 1.0)}. #' @param gamma SCAD concavity parameter. Default 3.7. #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. -#' @param selection Selection strategy: \code{"ld_quadratic"} (default) or -#' \code{"min_fbeta"}. +#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or +#' \code{"minFbeta"}. #' @param ... Additional arguments passed to \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. #' @examples @@ -1955,7 +1949,7 @@ scadRssWeights <- function( s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.7, alpha = 1.0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) { .penalizedRssWeights( @@ -1983,8 +1977,8 @@ scadRssWeights <- function( #' 0.5, 0.9, 1.0)}. #' @param gamma MCP concavity parameter. Default 3. #' @param alpha Elastic-net mixing (1 = pure L1). Default 1. -#' @param selection Selection strategy: \code{"ld_quadratic"} (default) or -#' \code{"min_fbeta"}. +#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or +#' \code{"minFbeta"}. #' @param ... Additional arguments passed to \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. #' @examples @@ -2007,7 +2001,7 @@ mcpRssWeights <- function( s = c(0.2, 0.5, 0.9, 1.0), gamma = 3.0, alpha = 1.0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) { .penalizedRssWeights( @@ -2044,8 +2038,8 @@ mcpRssWeights <- function( #' @param lambda Numeric vector of L1 penalty values (for L0L1). Default: #' \code{c(0)} (no L1 unless L0L1 is used). #' @param lambda2 L2 penalty weight (for L0L2). Default 0. -#' @param selection Selection strategy: \code{"ld_quadratic"} (default) or -#' \code{"min_fbeta"}. +#' @param selection Selection strategy: \code{"ldQuadratic"} (default) or +#' \code{"minFbeta"}. #' @param maxSwaps Maximum swap rounds per lambda. Default 100. #' @param ... Additional arguments passed to \code{penalizedRss()}. #' @return A numeric vector of SNP coefficient weights. @@ -2071,7 +2065,7 @@ l0learnRssWeights <- function( lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), lambda = NULL, lambda2 = 0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, ... ) { @@ -2123,13 +2117,11 @@ l0learnRssWeights <- function( #' @keywords internal ncvregWeights <- function(X, y, penalty, nfolds = 5, ...) { if (!requireNamespace("ncvreg", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install ncvreg: ", "https://cran.r-project.org/package=ncvreg" ) abort(msg) - # nocov end } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "ncvregWeights") @@ -2208,13 +2200,11 @@ mcpWeights <- function(X, y, nfolds = 5, ...) { #' @export l0learnWeights <- function(X, y, penalty = "L0", nFolds = 5, ...) { if (!requireNamespace("L0Learn", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install L0Learn: ", "https://cran.r-project.org/package=L0Learn" ) abort(msg) - # nocov end } eff.wgt <- matrix(0, ncol = 1, nrow = ncol(X)) keep <- .dropZeroVariance(X, "l0learnWeights") @@ -2270,13 +2260,11 @@ bglrWeights <- function( ... ) { if (!requireNamespace("BGLR", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install BGLR: ", "https://cran.r-project.org/package=BGLR" ) abort(msg) - # nocov end } eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "bglrWeights") @@ -2418,13 +2406,11 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' @export dprWeights <- function(X, y, fittingMethod = "VB", retainFit = FALSE, ...) { if (!requireNamespace("RcppDPR", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install RcppDPR: ", "https://cran.r-project.org/package=RcppDPR" ) abort(msg) - # nocov end } eff.wgt <- rep(0, ncol(X)) keep <- .dropZeroVariance(X, "dprWeights") @@ -2621,22 +2607,18 @@ mrmashWrapper <- function( # @noRd .mrmashRequirePackages <- function() { if (!requireNamespace("glmnet", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install glmnet: ", "https://cran.r-project.org/web/packages/glmnet/index.html" ) abort(msg) - # nocov end } if (!requireNamespace("mr.mashr", quietly = TRUE)) { - # nocov start msg <- glue( "To use this function, please install mr.mashr: ", "https://github.com/stephenslab/mr.mashr" ) abort(msg) - # nocov end } } @@ -2929,13 +2911,13 @@ computeW0 <- function(Bhat, ncomps) { return(w0) } -compute_w0 <- computeW0 #' Re-normalize mrmash weight w0 to have total weight sum to 1 #' @param w0 is the weight of mr.mash prior matrices that was generated from #' mr.mash() function. #' @return A named numeric vector of prior-matrix weights with the \code{null} #' component removed and the remaining weights renormalized to sum to 1. +#' @keywords internal rescaleCovW0 <- function(w0) { # remove null component w0 <- w0[names(w0) != "null"] @@ -2968,7 +2950,6 @@ rescaleCovW0 <- function(w0) { return(updatedW0) } -rescale_cov_w0 <- rescaleCovW0 ### Function to compute grids computeGrid <- function(bhat, sbhat) { @@ -3128,9 +3109,7 @@ buildMrmashPriorMatrices <- function( singletons = TRUE ) { if (!requireNamespace("mr.mashr", quietly = TRUE)) { - # nocov start abort("Package 'mr.mashr' is required.") - # nocov end } if (is.null(dataDrivenPriorMatrices) && !isTRUE(canonicalPriorMatrices)) { msg <- glue( diff --git a/R/relatednessQc.R b/R/relatednessQc.R index 285e558c..8246e896 100644 --- a/R/relatednessQc.R +++ b/R/relatednessQc.R @@ -9,8 +9,8 @@ #' .kin0 output). Must contain columns for IID1, IID2, and relatedness value. #' @param relatednessThreshold Kinship threshold above which individuals are #' considered related (default 0.0625, i.e. 2nd degree). -#' @param analysisType One of \code{"maximize_unrelated"} (default) or -#' \code{"maximize_cases"}. The latter preserves cases in case-control +#' @param analysisType One of \code{"maximizeUnrelated"} (default) or +#' \code{"maximizeCases"}. The latter preserves cases in case-control #' studies. #' @param relatednessIid1 Column name for first individual ID (default "IID1"). #' @param relatednessIid2 Column name for second individual ID (default "IID2"). @@ -19,7 +19,7 @@ #' @param relatednessValue Column name for the relatedness measure (default #' "PI_HAT"). #' @param phenoData A data.frame with columns \code{IID} and the column named by -#' \code{phenoCol}. Required when \code{analysisType = "maximize_cases"}. +#' \code{phenoCol}. Required when \code{analysisType = "maximizeCases"}. #' @param phenoCol Column name for the phenotype (default "pheno"). Expected to #' be binary (1 = case, 0 = control). #' @param otherCriterion Optional data.frame with additional filtering criteria @@ -47,7 +47,7 @@ filterRelatedness <- function( relatedness, relatednessThreshold = 0.0625, - analysisType = c("maximize_unrelated", "maximize_cases"), + analysisType = c("maximizeUnrelated", "maximizeCases"), relatednessIid1 = "IID1", relatednessIid2 = "IID2", relatednessFid1 = NULL, @@ -69,8 +69,8 @@ filterRelatedness <- function( analysisType <- arg_match(analysisType) p <- as.list(environment()) p$relatedness <- as_tibble(relatedness) - if (analysisType == "maximize_cases" && is.null(phenoData)) { - abort("Must provide phenoData when analysisType is 'maximize_cases'") + if (analysisType == "maximizeCases" && is.null(phenoData)) { + abort("Must provide phenoData when analysisType is 'maximizeCases'") } # Phase 1: graph-based pre-pruning of large components. highRelatedIndiv <- .relatednessPrune(p) @@ -90,11 +90,11 @@ filterRelatedness <- function( allExclude } -# Phase-2 dispatch: maximize_unrelated runs plinkQC directly; maximize_cases +# Phase-2 dispatch: maximizeUnrelated runs plinkQC directly; maximizeCases # preserves cases. Returns list(allExclude, kin). # @noRd .relatednessPhase2 <- function(kin, plinkqcArgs, analysisType, p) { - if (analysisType == "maximize_unrelated") { + if (analysisType == "maximizeUnrelated") { return(list( allExclude = .relatednessRunPlinkqc(kin, plinkqcArgs)$IID, kin = kin @@ -105,14 +105,12 @@ filterRelatedness <- function( # @noRd .relatednessRequirePackages <- function() { - # nocov start if (!requireNamespace("igraph", quietly = TRUE)) { abort("Package 'igraph' is required for filterRelatedness") } if (!requireNamespace("plinkQC", quietly = TRUE)) { abort("Package 'plinkQC' is required for filterRelatedness") } - # nocov end } # Graph pre-pruning: iteratively remove the highest-degree nodes of any @@ -211,7 +209,7 @@ filterRelatedness <- function( ) } -# maximize_cases: preserve cases, preferentially remove controls. Returns +# maximizeCases: preserve cases, preferentially remove controls. Returns # list(allExclude, kin) (kin is restricted to phenotyped individuals). # @noRd .relatednessMaximizeCases <- function(kin, plinkqcArgs, p) { diff --git a/R/sldscPostprocessingPipeline.R b/R/sldscPostprocessingPipeline.R index 4a91c1f1..1b6cf573 100644 --- a/R/sldscPostprocessingPipeline.R +++ b/R/sldscPostprocessingPipeline.R @@ -36,8 +36,10 @@ #' enrichmentP = setNames(rep(0.01, n), cats), #' propH2 = setNames(rep(0.2, n), cats), #' propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, -#' tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), +#' tauBlocks = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), 10, n, +#' dimnames = list(NULL, cats)), #' nBlocks = 10L) +#' } #' annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), #' annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) #' frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), @@ -48,9 +50,8 @@ #' joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) #' } #' traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -#' sd <- SldscData(annot = annot, frq = frq, traits = traits) -#' sldscPostprocessingPipeline(sldscData = sd) -#' } +#' sldscData <- SldscData(annot = annot, frq = frq, traits = traits) +#' sldscPostprocessingPipeline(sldscData = sldscData) #' @export sldscPostprocessingPipeline <- function( sldscData, @@ -108,7 +109,7 @@ sldscPostprocessingPipeline <- function( ) abort(msg) } - traitNames <- getTraitNames(sldscData) + traitNames <- getTraits(sldscData) if (length(traitNames) == 0L) { abort("sldscPostprocessingPipeline: SldscData has no traits.") } diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 36150a79..9757b2f9 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -193,11 +193,11 @@ readSldscAnnot <- function(targetAnnoDir, annotCols = NULL) { #' `.frq`). Falls back to all `*.frq` in the directory when #' the prefix matches nothing. #' @return A \code{data.frame}: \code{CHR}, \code{SNP}, \code{MAF}. -#' @importFrom vroom vroom +#' @importFrom readr read_table cols #' @importFrom tidyselect all_of #' @examples #' sldsc <- system.file("extdata", "sldsc", package = "pecotmr") -#' readSldscFrq(sldsc, plinkName = "reference.") +#' head(readSldscFrq(sldsc, plinkName = "reference.")) #' @export readSldscFrq <- function(frqfileDir, plinkName = "ADSP_chr") { if (!dir.exists(frqfileDir)) { @@ -1001,13 +1001,18 @@ sldscSubsetMeta <- function( ) } -# Read one .frq file's CHR/SNP/MAF columns. +# Read one .frq file's CHR/SNP/MAF columns. PLINK writes .frq +# whitespace-aligned rather than delimited, so the columns need read_table's +# whitespace collapsing: vroom guesses a single-space delimiter, reads the +# padding as empty fields, and shifts every value one or more columns left +# (CHR and SNP come back all-NA, MAF picks up NCHROBS). read_table also +# accepts the tab-delimited .frq some pipelines emit, since a tab is +# whitespace too. # @noRd .sldscReadFrqFile <- function(f) { - vroom( - f, - col_select = all_of(c("CHR", "SNP", "MAF")), - show_col_types = FALSE + select( + read_table(f, col_types = cols()), + all_of(c("CHR", "SNP", "MAF")) ) } diff --git a/R/sumstatsQc.R b/R/sumstatsQc.R index d19603ee..23aafade 100644 --- a/R/sumstatsQc.R +++ b/R/sumstatsQc.R @@ -2038,12 +2038,15 @@ raissSingleMatrixFromX <- function( #' Impute Summary Statistics Using LD (RAISS) #' -#' This function is a part of the statistical library for SNP imputation from: -#' https://gitlab.pasteur.fr/statistical-genetics/raiss/-/blob/master/raiss/stat_models.py -#' It is R implementation of the imputation model described in the paper by -#' Bogdan Pasaniuc, Noah Zaitlen, et al., titled "Fast and accurate imputation -#' of summary statistics enhances evidence of functional enrichment", published -#' in Bioinformatics in 2014. +#' An R port of the RAISS summary-statistic imputation library, described in +#' Julienne H, Shi H, Pasaniuc B, Aschard H (2019), "RAISS: robust and accurate +#' imputation from summary statistics", Bioinformatics 35(22):4837-4839. +#' \doi{10.1093/bioinformatics/btz466} +#' +#' The imputation model it implements is the one introduced in Pasaniuc B, +#' Zaitlen N, et al. (2014), "Fast and accurate imputation of summary +#' statistics enhances evidence of functional enrichment", Bioinformatics +#' 30(20):2906-2914. \doi{10.1093/bioinformatics/btu416} #' #' This function can process either a single LD matrix or a list of LD matrices #' for different blocks. For a list of matrices, it processes each block @@ -2528,7 +2531,6 @@ effectiveN <- function(nCase, nControl) { ) ) ) { - # nocov start msg <- glue( "krigingOutlierQc requires a susieR that provides ", "estimate_s_rss() and kriging_rss(); the installed susieR does ", @@ -2536,7 +2538,6 @@ effectiveN <- function(nCase, nControl) { "disable alleleFlipKriging." ) abort(msg) - # nocov end } } diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index 1bb8194c..1aa329e1 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -426,8 +426,9 @@ return(.tupleColumn(p, cn)) } } - # unreachable: cn is always drawn from allCols, so some part has it - NULL # nocov + # Callers always draw `cn` from allCols, so in practice some part has it; + # the NULL is the honest answer when none does. + NULL } # Internal: row-bind two or more per-tuple collection objects (TwasWeights / diff --git a/R/twasWeights.R b/R/twasWeights.R index 1e3699bd..8d7a4dfd 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -599,52 +599,52 @@ setMethod("show", "TwasWeights", function(object) { impl = "lassoWeights", args = list() ), - bayes_r = list( + bayesR = list( fn = "bayes_r_weights", impl = "bayesRWeights", args = list() ), - bayes_l = list( + bayesL = list( fn = "bayes_l_weights", impl = "bLassoWeights", args = list() ), - bayes_a = list( + bayesA = list( fn = "bayes_a_weights", impl = "bayesAWeights", args = list() ), - bayes_b = list( + bayesB = list( fn = "bayes_b_weights", impl = "bayesBWeights", args = list() ), - bayes_c = list( + bayesC = list( fn = "bayes_c_weights", impl = "bayesCWeights", args = list() ), - bayes_n = list( + bayesN = list( fn = "bayes_n_weights", impl = "bayesNWeights", args = list() ), - b_lasso = list( + bLasso = list( fn = "b_lasso_weights", impl = "bLassoWeights", args = list() ), - dpr_vb = list( + dprVb = list( fn = "dpr_vb_weights", impl = "dprVbWeights", args = list() ), - dpr_gibbs = list( + dprGibbs = list( fn = "dpr_gibbs_weights", impl = "dprGibbsWeights", args = list() ), - dpr_adaptive_gibbs = list( + dprAdaptiveGibbs = list( fn = "dpr_adaptive_gibbs_weights", impl = "dprAdaptiveGibbsWeights", args = list() @@ -673,7 +673,7 @@ setMethod("show", "TwasWeights", function(object) { ) ) -# Expand the `default` / `fast_default` preset strings to their method vectors. +# Expand the `default` / `fastDefault` preset strings to their method vectors. # @noRd .twasExpandPresets <- function(methods) { fastDefault <- c( @@ -687,11 +687,11 @@ setMethod("show", "TwasWeights", function(object) { "l0learn" ) if (length(methods) == 1) { - if (methods == "fast_default") { + if (methods == "fastDefault") { return(fastDefault) } if (methods == "default") { - return(c(fastDefault, "bayes_r", "bayes_c")) + return(c(fastDefault, "bayesR", "bayesC")) } } methods @@ -699,7 +699,7 @@ setMethod("show", "TwasWeights", function(object) { # Map short method names and presets to weightMethods lists. # @param methods A character vector of short method names, or a preset string -# ("default" or "fast_default"). +# ("default" or "fastDefault"). # @return A named list suitable for the weightMethods parameter. # @importFrom purrr map_chr set_names # @noRd @@ -711,8 +711,8 @@ setMethod("show", "TwasWeights", function(object) { unknown <- setdiff(methods, names(.twasMethodMap)) if (length(unknown) > 0) { msg <- glue( - "Unknown TWAS method(s): {str_flatten(unknown, ', ')}. ", - "Available methods: {str_flatten(names(.twasMethodMap), ', ')}" + "unknown method token(s): {str_flatten(unknown, ', ')}. ", + "Known tokens: {str_flatten(names(.twasMethodMap), ', ')}." ) abort(msg) } diff --git a/R/twasWeightsPipeline.R b/R/twasWeightsPipeline.R index d20819b9..1f6b1d86 100644 --- a/R/twasWeightsPipeline.R +++ b/R/twasWeightsPipeline.R @@ -212,7 +212,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # input-class compatibility to .fmCheckMethodCapabilities. mrash = list( individualImpl = "mrashWeights", - sumstatImpl = "mrAshRssWeights", + sumstatImpl = "mrashRssWeights", multivariate = FALSE ), lasso = list( @@ -240,7 +240,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { sumstatImpl = "mrmashRssWeights", multivariate = TRUE ), - dpr_gibbs = list( + dprGibbs = list( individualImpl = "dprGibbsWeights", sumstatImpl = "sdprWeights", multivariate = FALSE @@ -252,48 +252,48 @@ combineTwasWeights <- function(..., ldSketch = NULL) { multivariate = FALSE ), # Individual-only DPR variants (sumstat counterparts not implemented). - dpr_vb = list( + dprVb = list( individualImpl = "dprVbWeights", sumstatImpl = NULL, multivariate = FALSE ), - dpr_adaptive_gibbs = list( + dprAdaptiveGibbs = list( individualImpl = "dprAdaptiveGibbsWeights", sumstatImpl = NULL, multivariate = FALSE ), # qgg Bayes alphabet -- individual-only until qgg CRAN release. - bayes_a = list( + bayesA = list( individualImpl = "bayesAWeights", sumstatImpl = NULL, multivariate = FALSE ), - bayes_b = list( + bayesB = list( individualImpl = "bayesBWeights", sumstatImpl = NULL, multivariate = FALSE ), - bayes_c = list( + bayesC = list( individualImpl = "bayesCWeights", sumstatImpl = NULL, multivariate = FALSE ), - bayes_l = list( + bayesL = list( individualImpl = "bLassoWeights", sumstatImpl = NULL, multivariate = FALSE ), - bayes_n = list( + bayesN = list( individualImpl = "bayesNWeights", sumstatImpl = NULL, multivariate = FALSE ), - bayes_r = list( + bayesR = list( individualImpl = "bayesRWeights", sumstatImpl = NULL, multivariate = FALSE ), - b_lasso = list( + bLasso = list( individualImpl = "bLassoWeights", sumstatImpl = NULL, multivariate = FALSE @@ -337,7 +337,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { # Character `methods`: resolve regular tokens via .twasMethodLookup and append # empty stub entries for fine-mapping tokens with no learner counterpart (e.g. # fsusie) so the downstream gate can produce a method-specific error rather than -# "Unknown TWAS method". +# the generic "unknown method token(s)". # @noRd .twasNormalizeCharMethods <- function(methods) { fmExtra <- setdiff( @@ -396,16 +396,16 @@ combineTwasWeights <- function(..., ldSketch = NULL) { "mrash", "enet", "lasso", - "bayes_r", - "bayes_l", - "bayes_a", - "bayes_b", - "bayes_c", - "bayes_n", - "b_lasso", - "dpr_vb", - "dpr_gibbs", - "dpr_adaptive_gibbs", + "bayesR", + "bayesL", + "bayesA", + "bayesB", + "bayesC", + "bayesN", + "bLasso", + "dprVb", + "dprGibbs", + "dprAdaptiveGibbs", "scad", "mcp", "l0learn", @@ -428,16 +428,16 @@ combineTwasWeights <- function(..., ldSketch = NULL) { mrash = "mrash", enet = "enet", lasso = "lasso", - bayes_r = "bayes_r", - bayes_l = "bayes_l", - bayes_a = "bayes_a", - bayes_b = "bayes_b", - bayes_c = "bayes_c", - bayes_n = "bayes_n", - b_lasso = "b_lasso", - dpr_vb = "dpr_vb", - dpr_gibbs = "dpr_gibbs", - dpr_adaptive_gibbs = "dpr_adaptive_gibbs", + bayesR = "bayesR", + bayesL = "bayesL", + bayesA = "bayesA", + bayesB = "bayesB", + bayesC = "bayesC", + bayesN = "bayesN", + bLasso = "bLasso", + dprVb = "dprVb", + dprGibbs = "dprGibbs", + dprAdaptiveGibbs = "dprAdaptiveGibbs", scad = "scad", mcp = "mcp", l0learn = "l0learn", @@ -941,7 +941,7 @@ combineTwasWeights <- function(..., ldSketch = NULL) { #' embedded individual-level \code{QtlDataset} entries and the optional #' embedded \code{QtlSumStats}, then rbinds the results. #' @param methods A character vector of short method names, a preset string -#' (\code{"default"} or \code{"fast_default"}), or a named list of +#' (\code{"default"} or \code{"fastDefault"}), or a named list of #' \code{_weights = args} entries. For QtlSumStats / GwasSumStats #' inputs the default switches to the RSS preset (\code{c("susieRss", #' "susieInfRss", "lassosumRss", "prsCs", "sdpr")}). @@ -1529,7 +1529,7 @@ setMethod( # @noRd .twasSumStatsMethodTokens <- function(methods) { if (is.null(methods)) { - tokens <- c("lasso", "prsCs", "dpr_gibbs") + tokens <- c("lasso", "prsCs", "dprGibbs") return(list(tokens = tokens, methodArgs = .twasEmptyMethodArgs(tokens))) } if (is.character(methods)) { @@ -1821,7 +1821,7 @@ setMethod( ldSketch, cutoffs = NULL ) { - df <- getSumstatDf( + df <- getSumStatsDf( data, study = st, context = ctx, @@ -1994,7 +1994,7 @@ setMethod( ldSketch = NULL, cutoffs = NULL ) { - firstDf <- getSumstatDf( + firstDf <- getSumStatsDf( data, study = st, context = ctxNames[[1L]], @@ -2037,7 +2037,7 @@ setMethod( .twasQssFillContexts <- function(data, st, tr, ctxNames, variantIds, Z) { nVec <- numeric(length(ctxNames)) for (kk in seq_along(ctxNames)) { - d <- getSumstatDf( + d <- getSumStatsDf( data, study = st, context = ctxNames[[kk]], @@ -2442,13 +2442,11 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleQuadprog <- function(Pvalid, yObs, Kvalid) { if (!requireNamespace("quadprog", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'quadprog' is required for solver='quadprog'. ", "Install with: install.packages('quadprog')" ) abort(msg) - # nocov end } Dmat <- crossprod(Pvalid) @@ -2497,13 +2495,11 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleNnls <- function(Pvalid, yObs, Kvalid) { if (!requireNamespace("nnls", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'nnls' is required for solver='nnls'. ", "Install with: install.packages('nnls')" ) abort(msg) - # nocov end } fit <- tryCatch( @@ -2606,13 +2602,11 @@ setMethod("twasWeightsPipeline", "ANY", function(data, ...) { # @noRd .solveEnsembleGlmnet <- function(Pvalid, yObs, Kvalid, alpha = 1) { if (!requireNamespace("glmnet", quietly = TRUE)) { - # nocov start msg <- glue( "Package 'glmnet' is required for solver='glmnet'. ", "Install with: install.packages('glmnet')" ) abort(msg) - # nocov end } fit <- tryCatch( diff --git a/R/variantId.R b/R/variantId.R index 56de6bc2..af71ee71 100644 --- a/R/variantId.R +++ b/R/variantId.R @@ -384,23 +384,6 @@ normalizeVariantId <- function(ids, chrPrefix = TRUE, convention = NULL) { out } -#' Parse variant IDs into a data frame -#' -#' Convenience wrapper around \code{\link{parseVariantId}} returning the parsed -#' \code{chrom}/\code{pos}/\code{A2}/\code{A1} data frame for a vector of -#' variant IDs. -#' -#' @param variantId A character vector of variant IDs. -#' @return A data.frame with columns \code{chrom}, \code{pos}, \code{A2}, -#' \code{A1}. -#' @seealso \code{\link{parseVariantId}} -#' @examples -#' variantIdToDf("chr1:100:A:G") -#' @export -variantIdToDf <- function(variantId) { - parseVariantId(variantId) -} - # Complement a DNA allele string (A<->T, C<->G) for strand flipping. # @noRd .strandFlip <- function(ref) chartr("ATCG", "TAGC", ref) @@ -593,14 +576,14 @@ harmonizeAlleles <- function( variantDf <- targetData |> select(all_of(variantCols)) otherCols <- targetData |> select(-all_of(variantCols)) targetData <- bind_cols( - variantIdToDf(variantDf), + parseVariantId(variantDf), otherCols, .name_repair = "minimal" ) } else { - targetData <- variantIdToDf(targetData) + targetData <- parseVariantId(targetData) } - refVariants <- variantIdToDf(refVariants) + refVariants <- parseVariantId(refVariants) dropCols <- c("chromosome", "position", "ref", "alt", "variant_id") if (any(is_in(dropCols, colnames(targetData)))) { targetData <- select(targetData, -any_of(dropCols)) @@ -1252,48 +1235,6 @@ asGranges <- function(regions) { ) } -# Backwards-compat alias for external callers - -#' Test whether two genomic regions overlap -#' -#' @param regionA A region string ("chr1:100-200" or "1_100_200") or a -#' single-row data.frame with chrom/start/end columns. -#' @param regionB A region string or single-row data.frame. -#' @return Logical scalar: TRUE if the regions share at least one base pair. -#' @importFrom GenomicRanges GRanges -#' @importFrom IRanges IRanges findOverlaps -#' @examples -#' regionsOverlap("chr1:100-200", "chr1:150-250") -#' @export -regionsOverlap <- function(regionA, regionB) { - grA <- asGranges(regionA) - grB <- asGranges(regionB) - length(IRanges::findOverlaps(grA, grB)) > 0 -} - -#' Find which target regions overlap a query region -#' -#' @param query A single region string or single-row data.frame with -#' chrom/start/end columns. -#' @param targets A character vector of region strings, or a multi-row -#' data.frame with chrom/start/end columns. -#' @return Integer vector of 1-based indices into \code{targets} that overlap -#' the query. Empty integer vector if no overlaps. -#' @importFrom GenomicRanges GRanges -#' @importFrom IRanges IRanges findOverlaps -#' @importFrom S4Vectors subjectHits -#' @examples -#' query <- "chr1:100-200" -#' targets <- c("chr1:150-250", "chr1:300-400") -#' findOverlappingRegions(query = query, targets = targets) -#' @export -findOverlappingRegions <- function(query, targets) { - grQuery <- asGranges(query) - grTargets <- asGranges(targets) - hits <- IRanges::findOverlaps(grQuery, grTargets) - unique(S4Vectors::subjectHits(hits)) -} - #' Classify variant type from allele strings #' #' Determines whether each variant is a SNP, insertion, deletion, or diff --git a/R/vcfWriter.R b/R/vcfWriter.R index af2d89d9..31441f70 100644 --- a/R/vcfWriter.R +++ b/R/vcfWriter.R @@ -9,19 +9,17 @@ #' @importFrom purrr map map_chr keep set_names list_flatten NULL -#' @rdname writeSumstatsVcf +#' @rdname writeSumStatsVcf #' @export setMethod( - "writeSumstatsVcf", + "writeSumStatsVcf", signature("GwasSumStats"), function(x, outputPath, sampleName = NULL, study = NULL, ...) { - # nocov start if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort( - "Package 'VariantAnnotation' is required for writeSumstatsVcf" + "Package 'VariantAnnotation' is required for writeSumStatsVcf" ) } - # nocov end study <- .vcfResolveStudy(x, study) ss <- getSumStats(x, study = study) mc <- mcols(ss) @@ -87,10 +85,10 @@ setMethod( ) } -#' @rdname writeSumstatsVcf +#' @rdname writeSumStatsVcf #' @export setMethod( - "writeSumstatsVcf", + "writeSumStatsVcf", signature("FineMappingResultBase"), function( x, @@ -104,13 +102,11 @@ setMethod( splitByTrait = FALSE, ... ) { - # nocov start if (!requireNamespace("VariantAnnotation", quietly = TRUE)) { abort( - "Package 'VariantAnnotation' is required for writeSumstatsVcf" + "Package 'VariantAnnotation' is required for writeSumStatsVcf" ) } - # nocov end # Resolve the set of rows to write. With both selectors NULL and no # split flags, the collection must have exactly one row. Splitting @@ -171,7 +167,7 @@ setMethod( rows <- rows[as.character(x$method)[rows] == method] } if (length(rows) == 0L) { - abort("writeSumstatsVcf: no rows match the supplied selectors.") + abort("writeSumStatsVcf: no rows match the supplied selectors.") } if (!isTRUE(splitByContext) && !isTRUE(splitByTrait)) { if (length(rows) != 1L) { @@ -349,7 +345,7 @@ setMethod( base <- marg m <- marg } else { - msg <- glue("writeSumstatsVcf: entry [{sn}] has no variants to write") + msg <- glue("writeSumStatsVcf: entry [{sn}] has no variants to write") abort(msg) } list(base = base, m = m, hasPost = hasPost) @@ -571,10 +567,24 @@ setMethod( ) VariantAnnotation::writeVcf(vcf, tmpVcfStem, index = TRUE) # asBcf appends ".bcf" to destination, so strip the extension. - asBcf( - tmpVcfBgz, - dictionary = unique(chrom), - destination = str_remove(outputPath, "\\.bcf$") + # Rsamtools disabled asBcf() (>= 2.26 raises "temporarily disabled"), so + # the bare upstream error is translated into something actionable rather + # than surfacing as an opaque failure from a documented output format. + tryCatch( + asBcf( + tmpVcfBgz, + dictionary = unique(chrom), + destination = str_remove(outputPath, "\\.bcf$") + ), + error = function(e) { + msg <- glue( + "writeSumStatsVcf: BCF output needs a working ", + "Rsamtools::asBcf(), which the installed Rsamtools does not ", + "provide (\"{conditionMessage(e)}\"). Write a bgzipped VCF ", + "instead by giving the output path a .vcf.bgz extension." + ) + abort(msg) + } ) } diff --git a/_pkgdown.yml b/_pkgdown.yml index 907d04aa..653509b1 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -52,11 +52,12 @@ articles: contents: - constructing-qtl-datasets - constructing-sumstats - - title: "Quality Control" + - title: "LD and quality control" desc: > - Allele alignment and LD-mismatch QC for GWAS and QTL summary - statistics. + Loading, computing and conditioning LD references, and the allele + alignment and LD-mismatch QC that matches summary statistics to them. contents: + - ld-infrastructure - rss-qc - title: "Fine-mapping" desc: > @@ -64,14 +65,25 @@ articles: summary statistics, and GWAS summary statistics. contents: - fine-mapping + - finemapping-postprocessing - title: "TWAS" desc: > Training TWAS weights from QTL data (individual-level and - summary-statistics, single and multi-context) and computing - per-gene TWAS Z-scores from GWAS summary statistics. + summary-statistics, single and multi-context), computing per-gene + TWAS Z-scores from GWAS summary statistics, and fine-mapping genes + jointly with SNPs so a gene's PIP is conditioned on the signal + beside it. contents: - twas-weights - twas-zscore + - ctwas-pipeline + - title: "Cross-context modeling" + desc: > + Multivariate adaptive shrinkage across contexts: learning the + covariance structure of effect sharing and shrinking per-context + estimates toward it. + contents: + - mash-pipeline - title: "Colocalization" desc: > Pairwise QTL/GWAS colocalization (coloc.bf_bf) and multi-trait @@ -79,8 +91,13 @@ articles: contents: - coloc-pipeline - colocboost-pipeline - - title: "Enrichment Analysis" + - title: "Heritability and enrichment" + desc: > + SNP heritability from GWAS summary statistics by four estimators, + functional enrichment across annotations, postprocessing of external + polyfun sLDSC runs, and per-variant molecular-QTL enrichment. contents: + - heritability - xqtl-enrichment - title: "Resources" navbar: ~ @@ -206,7 +223,7 @@ reference: - getVariantIds - intersectVariants - resolveWeights - - writeSumstatsVcf + - writeSumStatsVcf - subtitle: "QtlFineMappingResult" contents: @@ -258,18 +275,19 @@ reference: - subtitle: "GwasSumStats" contents: + - as.data.frame.GwasSumStats - combineGwasSumStats - - getSumstatDf + - getSumStatsDf - "getSumStats,GwasSumStats-method" - getVarY - - writeSumstatsVcf + - writeSumStatsVcf - subtitle: "QtlSumStats" contents: - combineQtlSumStats - getContexts - getSignificantQtls - - getSumstatDf + - getSumStatsDf - getSumStats - getTraitPosition - getTraits @@ -396,7 +414,6 @@ reference: - getAnnotCols - getAnnotData - getFrqData - - getTraitNames - getTraitRun - getTraitRuns @@ -456,13 +473,10 @@ reference: design-matrix conditioning utilities. contents: - loadLdMatrix - - loadLdSketch - - loadLdBlock - computeLd - checkLd - enforceDesignFullRank - ldClumpByScore - - ldLoader - ldPruneByCorrelation - filterVariantsByLdReference @@ -484,13 +498,10 @@ reference: (`chr:pos:A2:A1`) and genomic regions (`chr:start-end`). contents: - parseVariantId - - variantIdToDf - normalizeVariantId - classifyVariantType - parseRegion - regionToDf - - regionsOverlap - - findOverlappingRegions - asGranges - title: "Fine-mapping" @@ -571,7 +582,7 @@ reference: - subtitle: "mr.mash / mr.ash" contents: - mrashWeights - - mrAshRssWeights + - mrashRssWeights - mrmashWeights - mrmashRssWeights - mrmashWrapper @@ -629,12 +640,16 @@ reference: - title: "Heritability and enrichment" desc: > - Heritability estimation, LD-score computation, stratified - LD-score regression utilities, and per-variant QTL/GWAS - enrichment analysis (low-level kernel that powers - \code{qtlEnrichmentPipeline}). + Heritability estimation, the two builders that turn a loaded LD + reference into the statistic each estimator needs + (\code{buildLdEigen} for LDER/HDL, \code{buildLdScore} for + g-LDSC), LD-score computation, stratified LD-score regression + utilities, and per-variant QTL/GWAS enrichment analysis (low-level + kernel that powers \code{qtlEnrichmentPipeline}). contents: - estimateH2 + - buildLdEigen + - buildLdScore - computeLdScores - computeSldscAnnotSd - computeSldscMRef @@ -688,27 +703,6 @@ reference: - ldScoreExample - h2EstimateExample - - title: internal - desc: > - Implementation details that have `.Rd` topics but no front-facing - role. Hidden from the reference index but still searchable and - rendered. - contents: - - GenotypeHandle - - GenotypeHandle-class - - getSnpInfo - - getFormat - - getPath - - getSampleIds - - getPgenPtr - - getNSamples - - getChromPaths - - getGenotypeHandle - - extractBlockGenotypes - - genotypeDelayedArray - - as.data.frame.GwasSumStats - - rescaleCovW0 - footer: structure: left: developed_by diff --git a/data/ctwasEstExample.rda b/data/ctwasEstExample.rda index 3e680a86..656d1143 100644 Binary files a/data/ctwasEstExample.rda and b/data/ctwasEstExample.rda differ diff --git a/data/ctwasFinemapExample.rda b/data/ctwasFinemapExample.rda index 983d0502..252043c0 100644 Binary files a/data/ctwasFinemapExample.rda and b/data/ctwasFinemapExample.rda differ diff --git a/data/ctwasInputsExample.rda b/data/ctwasInputsExample.rda index b2735b47..316c8d79 100644 Binary files a/data/ctwasInputsExample.rda and b/data/ctwasInputsExample.rda differ diff --git a/data/ldEigenExample.rda b/data/ldEigenExample.rda index ec2cd522..288269e7 100644 Binary files a/data/ldEigenExample.rda and b/data/ldEigenExample.rda differ diff --git a/data/ldScoreExample.rda b/data/ldScoreExample.rda index 3426503e..cb06d07a 100644 Binary files a/data/ldScoreExample.rda and b/data/ldScoreExample.rda differ diff --git a/inst/extdata/sldsc/reference.2.annot.gz b/inst/extdata/sldsc/reference.2.annot.gz index 85ebf0c5..1fd0b45c 100644 Binary files a/inst/extdata/sldsc/reference.2.annot.gz and b/inst/extdata/sldsc/reference.2.annot.gz differ diff --git a/inst/extdata/sldsc_trait/sumstats2.parquet.log b/inst/extdata/sldsc_trait/sumstats2.parquet.log new file mode 100644 index 00000000..1b97dcff --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats2.parquet.log @@ -0,0 +1,41 @@ +********************************************************************* +* LD Score Regression (LDSC) +* Version 1.0.0 +* (C) 2014-2015 Brendan Bulik-Sullivan and Hilary Finucane +* Broad Institute of MIT and Harvard / MIT Department of Mathematics +* GNU General Public License v3 +********************************************************************* +Call: +./ldsc.py \ +--out /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats2.parquet \ +--h2 data/polyfun_new/example_data/sumstats2.parquet \ +--ref-ld-chr output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations. \ +--w-ld-chr data/polyfun_new/example_data/weights. \ +--overlap-annot \ +--print-coefficients \ +--print-delete-vals \ +--not-M-5-50 + +Beginning analysis at Sat Jun 6 13:20:20 2026 +Reading summary statistics from data/polyfun_new/example_data/sumstats2.parquet ... +Read summary statistics for 3475 SNPs. +Reading reference panel LD Score from output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations.[1-22] ... +Read reference panel LD Scores for 3475 SNPs. +Reading regression weight LD Score from data/polyfun_new/example_data/weights.[1-22] ... +Read regression weight LD Scores for 182454 SNPs. +After merging with reference panel LD, 3475 SNPs remain. +After merging with regression SNP LD, 3475 SNPs remain. +WARNING: number of SNPs less than 200k; this is almost always bad. +Removed 1 SNPs with chi^2 > 383.29 (3474 SNPs remain) +Printing block jackknife delete values to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats2.parquet.delete. +Printing partitioned block jackknife delete values to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats2.parquet.part_delete. +Total Observed scale h2: 0.0041 (0.0022) +Categories: ANNOT_0 Coding_UCSC_common_1 Coding_UCSC_lowfreq_1 Conserved_LindbladToh_common_1 Conserved_LindbladToh_lowfreq_1 Repressed_Hoffman_common_1 Repressed_Hoffman_lowfreq_1 base_1 +Lambda GC: 1.7321 +Mean Chi^2: 2.6775 +Intercept: 0.949 (0.2106) +Ratio < 0 (usually indicates GC correction). +Reading annot matrix from output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations.[1-22] ... +Results printed to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats2.parquet.results +Analysis finished at Sat Jun 6 13:20:24 2026 +Total time elapsed: 3.54s diff --git a/inst/extdata/sldsc_trait/sumstats2.parquet.part_delete b/inst/extdata/sldsc_trait/sumstats2.parquet.part_delete new file mode 100644 index 00000000..40d1d89f --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats2.parquet.part_delete @@ -0,0 +1,200 @@ +4.398678610919047727e-07 2.632403154671534914e-07 7.753861154509423938e-07 7.895847253888882787e-07 -6.161268796011770880e-07 -7.022997238400619024e-08 -6.692014740468279885e-08 4.117342208364918507e-08 +4.391547447168515157e-07 2.397048098261623566e-07 8.896466472524197776e-07 7.720155496030320318e-07 -6.764176568961459146e-07 -6.981341586206755820e-08 -6.613681835261226555e-08 4.187126176884431396e-08 +4.401253710630010942e-07 2.218789562215892423e-07 1.004371320954767290e-06 7.708671789647172173e-07 -6.199228936212794174e-07 -6.879252578743767789e-08 -7.023801201219374126e-08 4.116385594311963089e-08 +4.086863542131332339e-07 2.496722850230042126e-07 7.671728640025426537e-07 7.798632555581386478e-07 -6.753235319603122075e-07 -6.892074915178602934e-08 -6.744031372014567557e-08 4.053864033564856550e-08 +4.150677603179050683e-07 2.450050501329179307e-07 8.306044845496777955e-07 7.815236053292336868e-07 -6.446077901134142474e-07 -6.854828878027841164e-08 -6.677893758576423348e-08 4.146513389130298571e-08 +4.657322594210540074e-07 2.462864513125106957e-07 7.868085746991751982e-07 7.648282805370678655e-07 -6.005848921690486713e-07 -6.879025201974696859e-08 -6.898458229902799943e-08 4.141421557038554312e-08 +4.320524118588095823e-07 2.351625159199282987e-07 8.322807461279556474e-07 7.999764281695998257e-07 -6.750075820993115136e-07 -6.905974307745575505e-08 -6.822316895459675013e-08 4.132507289946923414e-08 +3.999202686544790813e-07 2.566818008064397511e-07 8.015016571492140114e-07 7.694511863348026488e-07 -5.936861201005408769e-07 -6.861633715820080878e-08 -6.910427200256170749e-08 4.111318350676642630e-08 +4.017944670724921545e-07 2.158807462948054806e-07 8.182960328770643624e-07 7.849794832595972905e-07 -6.516824032441080707e-07 -7.037246942715392134e-08 -6.744736431455908391e-08 4.184230416797746887e-08 +4.008399838030359111e-07 2.399694003831243226e-07 7.975426467401979486e-07 7.714227383199640895e-07 -6.169904383411683758e-07 -6.962705182317907514e-08 -6.850257913858009208e-08 4.176098910512150600e-08 +4.305012355878774237e-07 2.431481624814710567e-07 7.914424325008639549e-07 7.683682011386910338e-07 -6.105167121710798775e-07 -6.952752323906953283e-08 -6.868168425086323108e-08 4.193051858399405726e-08 +4.292146811509226397e-07 2.474528942237066142e-07 7.805832739251978690e-07 7.667545709571303571e-07 -5.917443792873114910e-07 -6.917390496168977915e-08 -6.946410001677274587e-08 4.146846550071523890e-08 +4.318658662551106017e-07 2.367190513736308818e-07 8.268182870160267316e-07 7.659864959986249348e-07 -6.206763058726347959e-07 -6.858710658791404577e-08 -6.846201533138510628e-08 4.134396512090200370e-08 +3.974041890732465920e-07 2.484551414878873171e-07 7.949148516738299397e-07 7.710263461117808960e-07 -6.143292729200770209e-07 -6.917782352681582642e-08 -6.749432758139764830e-08 4.176574740685544837e-08 +4.205032085351730220e-07 2.385192064945878577e-07 8.365645462825194697e-07 7.779477010740751749e-07 -6.941888821140505167e-07 -7.036157898802168338e-08 -6.612930385082636783e-08 4.222794560498573705e-08 +4.028277080569438663e-07 2.399769237418845179e-07 7.962216550580185675e-07 7.645771767350050656e-07 -5.907149268720360385e-07 -6.838679091828238895e-08 -7.324495401432145802e-08 4.127035147657157443e-08 +3.790930273773455652e-07 2.457268407741435810e-07 7.974803529668788692e-07 7.730522326828497988e-07 -6.034040251874535852e-07 -6.977219904743751600e-08 -6.761500030953306339e-08 4.173422232794312533e-08 +4.169816936612790646e-07 2.421549197433920447e-07 7.917682172062022228e-07 7.704845794555663360e-07 -6.274155383293769702e-07 -6.912157195132016721e-08 -6.742674119022783623e-08 4.123855629566221728e-08 +4.468980518400812244e-07 2.337905096994461097e-07 8.141176135744454731e-07 7.759439819080656286e-07 -6.182208209740752861e-07 -6.993728033547585198e-08 -6.816693207983990521e-08 4.201081086159217019e-08 +4.214917171197067516e-07 2.387207161893529575e-07 8.000001542138659655e-07 7.699871537599711130e-07 -6.206308502228530241e-07 -6.961051965742109091e-08 -6.829069521051015154e-08 4.166293214387438805e-08 +2.918612362591790102e-07 2.642612428965265290e-07 8.447398259209046820e-07 7.630575996410687108e-07 -6.978378138180825935e-07 -6.612536458140456817e-08 -5.992812337271334511e-08 4.093272951136712735e-08 +4.320719948309934891e-07 2.400190446944280248e-07 7.972127841993523445e-07 7.693917277476520016e-07 -6.182675873470248707e-07 -6.959803902611043392e-08 -6.862355287881856904e-08 4.182397765717620357e-08 +5.227267731994336063e-07 2.598594266813103501e-07 7.625720322565821528e-07 7.066531232958551000e-07 -5.623684428530683603e-07 -6.823342608668132485e-08 -7.066558087419330098e-08 4.224965091308942582e-08 +4.280287177682344846e-07 2.431804420814964277e-07 8.162226939041019648e-07 7.676558470743523431e-07 -6.141689278641394379e-07 -6.937929703298807611e-08 -6.883540675095800792e-08 4.147330595779623447e-08 +4.331777453156313075e-07 2.354952406618962967e-07 7.871456187300487409e-07 7.639905107667620679e-07 -6.153427990075204799e-07 -7.018973718579272709e-08 -6.928884204730394644e-08 4.202550115917502537e-08 +4.630185126296565279e-07 2.382482112958605366e-07 7.955996212261714078e-07 7.676210901501877535e-07 -5.834413696344003920e-07 -7.046643240059389186e-08 -6.962401536501870087e-08 4.211640448630624628e-08 +4.127004090704840842e-07 2.420973196316967305e-07 8.022210283638721884e-07 7.683601738260355018e-07 -6.227158359540197062e-07 -6.910019829952926677e-08 -6.730795791596623463e-08 4.128227129045683130e-08 +4.392269528672922854e-07 2.399684425519408137e-07 7.646030070048460408e-07 7.743220123876732759e-07 -5.716765244656911290e-07 -6.966118263351620651e-08 -6.948158150416246913e-08 4.166707829856076724e-08 +4.448233537120252349e-07 2.401612301699680825e-07 8.034434058803377699e-07 7.704433060073470949e-07 -6.487147578770470182e-07 -6.941817012357981858e-08 -6.874919472523740945e-08 4.161106964690629922e-08 +4.233063182794093630e-07 2.334409364300961314e-07 8.023816893236854895e-07 7.720235134451664623e-07 -5.958103263948965580e-07 -6.984446087406997522e-08 -6.924379189625590198e-08 4.186200744481726129e-08 +4.304272428010057307e-07 2.506288978360323557e-07 8.767393547508140679e-07 7.805730525368146091e-07 -5.882959191532147737e-07 -6.847329006287513679e-08 -6.838578419487130988e-08 4.074492995023272750e-08 +4.280539478217574798e-07 2.384814581828300469e-07 7.747722691346601008e-07 7.690424925156271210e-07 -5.925795781025500482e-07 -6.977869781699568164e-08 -6.853499231804875716e-08 4.185366245255187985e-08 +4.360625311706332234e-07 2.561832753982923388e-07 7.682030348980437109e-07 7.752733411659424127e-07 -6.172042246963395036e-07 -6.892098369384747889e-08 -6.784491857296595110e-08 4.127499408639157904e-08 +4.403157865592248911e-07 2.216924811102471832e-07 8.325903593246850381e-07 7.694423387362104890e-07 -6.282563450496212201e-07 -6.790515202206776961e-08 -6.807913947971753152e-08 4.074488540470070704e-08 +4.790590941189816051e-07 2.383597130690053814e-07 8.218276329044614442e-07 7.740040700459026901e-07 -6.182387023618484110e-07 -6.825409180551422062e-08 -6.909213129131112747e-08 4.099221992307664140e-08 +4.164730456249006786e-07 2.498211837532391886e-07 7.969397642143681360e-07 7.672028666721041874e-07 -5.860333346410497658e-07 -6.897856801682778492e-08 -7.086851333462993906e-08 4.156608830550678267e-08 +4.701428363919357144e-07 2.443508044076036817e-07 7.904091842067674654e-07 7.641913601719613724e-07 -6.182940246675569346e-07 -6.997052200839605346e-08 -6.937417688940729201e-08 4.197035871989662342e-08 +4.413219359686031015e-07 2.400951065178609299e-07 7.896952705208215324e-07 7.761469743886101465e-07 -6.231943901063546219e-07 -7.036654870595489717e-08 -6.814370758077915221e-08 4.170645282713762714e-08 +4.303842016343371630e-07 2.469254240186225739e-07 7.533987395560922059e-07 7.640915403722515344e-07 -6.060334796978969166e-07 -6.974308136644647132e-08 -6.845894711941691257e-08 4.200492372408922172e-08 +4.479407217577668923e-07 2.426665737553110296e-07 7.879262322840433720e-07 7.706957696163717843e-07 -6.181306444849585995e-07 -6.936153661435456529e-08 -6.784358291392929430e-08 4.136477228458387334e-08 +4.187133243315769328e-07 2.371005358020556110e-07 8.026601202957628624e-07 7.808824030247997715e-07 -6.300998954291499314e-07 -7.012149017911698878e-08 -6.686208618435171923e-08 4.175548556718054540e-08 +4.775910165497419686e-07 2.388988040299401838e-07 8.012747260474212111e-07 7.732097382515511324e-07 -6.268805721597726711e-07 -6.985774390744017067e-08 -6.838844041253742907e-08 4.190949629988197057e-08 +4.305329990228724349e-07 2.408676309584262413e-07 8.002103212381471676e-07 7.720764517959789952e-07 -6.213380138846925837e-07 -6.952941883987920576e-08 -6.845867694702062765e-08 4.164819942944249878e-08 +4.355141685676557446e-07 2.392641131589247988e-07 7.963757485809623451e-07 7.727314693746391190e-07 -6.223924918085073873e-07 -6.949044323643729725e-08 -6.849926605558981501e-08 4.174591815928108057e-08 +4.387656450085417273e-07 2.346226861931570708e-07 7.785214541317740201e-07 7.809040238058174819e-07 -5.604019711499559784e-07 -7.003338057759305502e-08 -6.986198940950239984e-08 4.179477353713732938e-08 +4.169069606581868220e-07 2.274975357471526988e-07 7.979613174085723700e-07 7.848208581203086934e-07 -6.117930988046962976e-07 -6.955797891945036606e-08 -6.785928147913931337e-08 4.158970035494113704e-08 +4.469126208786145154e-07 2.379380212269531274e-07 8.700933688578144254e-07 7.695308598818043133e-07 -6.330969212757353491e-07 -6.922384405717561224e-08 -6.863333497702531735e-08 4.124762390090604473e-08 +4.385132269002058407e-07 2.364538489899673604e-07 7.900548856090851888e-07 7.736347987796518077e-07 -6.276998461012166385e-07 -7.032698309216659093e-08 -6.918989747656123342e-08 4.223301557223074950e-08 +4.264566549604455839e-07 2.361935518135470512e-07 8.091229938829143081e-07 8.072766394211655838e-07 -6.586294195677035296e-07 -6.937226930250559184e-08 -6.659746436128694795e-08 4.103764824585857912e-08 +4.079912704589801983e-07 2.373103957937296162e-07 8.226373566407607880e-07 7.850812372708883630e-07 -6.243101806562321860e-07 -6.900566021077098033e-08 -6.708976310539923564e-08 4.087198320673281831e-08 +4.496390775046001138e-07 2.518456861155297253e-07 7.665550112952869725e-07 7.626513583762962589e-07 -6.256529732521454878e-07 -7.002367978293483323e-08 -6.895737929223940156e-08 4.197929305594655825e-08 +4.364015922916321415e-07 2.396011133152678489e-07 7.835441762585683958e-07 7.673015823677097773e-07 -5.968973649281371177e-07 -6.977114708915727231e-08 -6.893149578540496672e-08 4.181723824206062835e-08 +4.220564606335455773e-07 2.315054390487229085e-07 8.137701666152989542e-07 7.819686796405421761e-07 -6.358257426312128789e-07 -6.901192973337771239e-08 -6.722474363303256351e-08 4.128319134034982686e-08 +4.204084329340420447e-07 2.400918476703613076e-07 7.997285710619330700e-07 7.715430564416235567e-07 -6.255590466967303172e-07 -6.986016761852666068e-08 -6.793824313418759873e-08 4.189825290497476206e-08 +4.343905332370435882e-07 2.401238847019708948e-07 8.115290687059698493e-07 7.712558013724791391e-07 -6.546359406686559418e-07 -6.927365481332056381e-08 -6.786872477132895588e-08 4.170117127615565924e-08 +4.262291248159690440e-07 2.408175082678319451e-07 8.060426923726306066e-07 7.761915846774655732e-07 -6.264838318849131697e-07 -6.905229034831579833e-08 -6.809954515085754552e-08 4.139784181355470798e-08 +4.469115949295682428e-07 2.404850576133723648e-07 7.937709283209816776e-07 7.695517503155971713e-07 -6.190349176489140062e-07 -6.970362518575279297e-08 -6.881017133931279962e-08 4.181874066417604564e-08 +4.346664276536880120e-07 2.405329448222323347e-07 7.951450881030086220e-07 7.709853604136338759e-07 -6.178352279552832577e-07 -6.913194815596909653e-08 -6.819277237520174147e-08 4.164580318797121691e-08 +4.483483951114882392e-07 2.399438404168399181e-07 7.818551923421342533e-07 7.716317392519541755e-07 -6.481432932569839859e-07 -7.000199365624612937e-08 -6.944859582763225513e-08 4.258132194203539732e-08 +4.559373695650025048e-07 2.388104413049390250e-07 7.929874582103535378e-07 7.690520326608078108e-07 -6.053939425875058664e-07 -6.959818304160099189e-08 -6.836485687725284362e-08 4.167092216397594160e-08 +4.280694377194991306e-07 2.287146031263431526e-07 8.144929551525322723e-07 7.689667199479541098e-07 -6.234547080441049719e-07 -6.960828079711121450e-08 -6.981561496155775476e-08 4.194700447150836743e-08 +4.569087521173331271e-07 2.583845539396020682e-07 7.403598000527329983e-07 7.706637349273145573e-07 -5.760972779984588794e-07 -6.860581804096010516e-08 -6.779320945360254865e-08 4.062642545044007341e-08 +3.810016306072325933e-07 2.374787197166041058e-07 8.044082590729142626e-07 7.671966949996751790e-07 -6.175266386082234213e-07 -7.024827206013200924e-08 -7.069565257694702391e-08 4.199775088705268279e-08 +4.784827976620785539e-07 2.409777863702705468e-07 7.973666128489876787e-07 7.674453817439580703e-07 -5.983667255194847330e-07 -6.930887598509427381e-08 -7.150377068669243173e-08 4.175856848149553957e-08 +4.221863194760529892e-07 2.413137278635056752e-07 7.762729847184420437e-07 7.701243151389219257e-07 -5.758341478816991971e-07 -6.988627935298245276e-08 -7.583284557184431240e-08 4.225999258933470064e-08 +5.109859755137334325e-07 2.396280263415680164e-07 8.388144002513021334e-07 7.764702563038314522e-07 -6.362723939460144292e-07 -6.897970106199596955e-08 -6.556774338242170672e-08 4.124566034981406731e-08 +4.418793264932593405e-07 2.391727461790518583e-07 8.021568855664370912e-07 7.726644830389526576e-07 -6.225807396490863116e-07 -6.941104817878253020e-08 -6.891979254167080436e-08 4.180944576860058843e-08 +4.053251825891735492e-07 2.321602616671409133e-07 8.729159353928723389e-07 7.986474356261389118e-07 -7.299026157997129761e-07 -6.891307792878634829e-08 -6.808669375760878477e-08 4.096585129973213073e-08 +4.526544700119781400e-07 2.373906510607361162e-07 7.841388325486542400e-07 7.841085037374851909e-07 -6.081588169996920615e-07 -7.005712940723564807e-08 -6.956758201940144557e-08 4.162536769902926410e-08 +4.245474482546700711e-07 2.447832990197692212e-07 7.989521587955020936e-07 7.786839603959798563e-07 -6.232830438104305697e-07 -6.952244383705202488e-08 -6.786408792688571047e-08 4.162530743047103012e-08 +4.284231990831062983e-07 2.413792265237660055e-07 7.969804007183286223e-07 7.679445298036470172e-07 -6.102943760714773379e-07 -6.885831555146684674e-08 -6.901639544366166095e-08 4.146571322148189715e-08 +4.120625137251125689e-07 2.639459181464948712e-07 7.328490504779606241e-07 7.152176001004652517e-07 -5.574707253719670654e-07 -6.835397798738388507e-08 -7.195918251148232863e-08 4.223325448462162892e-08 +4.455322737816479658e-07 2.501407176933645431e-07 7.796657618700924876e-07 7.676151450350124824e-07 -5.987802868764703572e-07 -6.919020745513628897e-08 -6.941590325322539304e-08 4.168803313200658725e-08 +5.380155479574712630e-07 2.385331053151359540e-07 7.820561297453287383e-07 7.779495865550933888e-07 -6.247416129039119431e-07 -6.926016148193785917e-08 -6.900743710797285229e-08 4.116082203748002004e-08 +4.199915921988281684e-07 2.474205289816520897e-07 7.975217214925337834e-07 7.658470034616662814e-07 -6.280833713472609520e-07 -6.868465473685260695e-08 -7.125152771918227046e-08 4.161006921506239209e-08 +4.335953716338403213e-07 2.324498362908321581e-07 7.743999243090463118e-07 7.673557947334240176e-07 -6.238612692014127618e-07 -7.061914830658095421e-08 -7.017804591726249959e-08 4.230848574877298598e-08 +4.243083249961848887e-07 2.402411070335264422e-07 8.009495496854721996e-07 7.693041667803642126e-07 -6.156619128500989907e-07 -6.944374545569566336e-08 -6.974846113808737581e-08 4.178377856471836231e-08 +4.146941151485433353e-07 2.382173770991429162e-07 7.807086289717186921e-07 7.757563103896680456e-07 -6.159403871782269249e-07 -6.932196871852351065e-08 -6.806956475801734828e-08 4.144379451349913041e-08 +4.337537224552198893e-07 2.534295129015900649e-07 7.796400677830524096e-07 7.654522768768598487e-07 -6.173723304270661871e-07 -6.917722171590146617e-08 -6.860219679441783218e-08 4.163197907786467009e-08 +4.335581536693378188e-07 2.376375617630237654e-07 8.330725071741566671e-07 7.683761739763047763e-07 -6.354812429976610567e-07 -6.924060622645990104e-08 -6.833667186859875955e-08 4.170901691131254875e-08 +4.264125407136358662e-07 2.418445375190929126e-07 7.907389005992290964e-07 7.699734765106267861e-07 -6.084820562306851881e-07 -6.916859923971494643e-08 -6.910304061131206197e-08 4.164895272865335880e-08 +4.397626434233551343e-07 2.457864112441737477e-07 7.902587902574593586e-07 7.759448047974123357e-07 -6.231889813389488828e-07 -6.940217924434624375e-08 -6.849638389473233022e-08 4.157906895704731339e-08 +4.300820429389418383e-07 2.378097277678443654e-07 8.058284986305830093e-07 7.666571439054725792e-07 -6.200347165243495340e-07 -6.894219382222621908e-08 -6.991356105309731471e-08 4.146299622401059237e-08 +4.175094178695833868e-07 2.402990421319570594e-07 7.992942985356973908e-07 7.723187126353017191e-07 -6.227462776392344130e-07 -6.944853804208183462e-08 -6.869875372551170048e-08 4.182118809983440818e-08 +4.059134205490584343e-07 2.333617306126323770e-07 7.826027510368261934e-07 7.747426619924629247e-07 -6.093432064488885632e-07 -6.917790579774342370e-08 -6.758318240416287145e-08 4.195511220720077946e-08 +4.550450264631271730e-07 2.333610787910962275e-07 8.075117509752931689e-07 7.736425584422456419e-07 -6.134083231803675562e-07 -7.023584272301283521e-08 -6.869234776853503447e-08 4.190664796914380695e-08 +4.284399033146040864e-07 2.447403595589837616e-07 8.139305129023100933e-07 7.725575382297948968e-07 -6.167687083980831001e-07 -6.880391605446959013e-08 -6.757629299570976472e-08 4.118570647156244019e-08 +4.488223055705750137e-07 2.391799497882738766e-07 7.957377147292726793e-07 7.722798491968221465e-07 -6.216131959174548578e-07 -6.917456009302111962e-08 -6.822497258365265289e-08 4.164449379884474710e-08 +4.280584666094850754e-07 2.511693165103064858e-07 7.695901639489430879e-07 7.729438652297678804e-07 -5.767868778558414206e-07 -6.879133740456161195e-08 -6.904443230470073826e-08 4.097280469098156209e-08 +3.823155380363365077e-07 2.357019418613070667e-07 7.960243120500500933e-07 7.776780280206084237e-07 -6.116326450521530272e-07 -7.003734501627714217e-08 -7.006625537637814921e-08 4.173659384404352090e-08 +4.308804391089532213e-07 2.425091779048546436e-07 8.070256889018406074e-07 7.731961906933096078e-07 -6.242034277967468592e-07 -6.912524347976451701e-08 -6.760048668906786634e-08 4.129078888733269787e-08 +4.325118923659268431e-07 2.386600897182859505e-07 8.027454659059121383e-07 7.688775119630030975e-07 -6.218915128849059586e-07 -6.977953781409554978e-08 -6.967756432693199693e-08 4.190107376362305785e-08 +4.354093722532271212e-07 2.431156055139336023e-07 8.084718120652096730e-07 7.706186974633720599e-07 -6.287674322791672762e-07 -6.895595966350087476e-08 -6.851172703551519215e-08 4.159863402747571387e-08 +4.668313232029133998e-07 2.416332036304014113e-07 7.831650933852025051e-07 7.695827660884690590e-07 -5.895296020442134765e-07 -6.922449690366518394e-08 -7.444038087281339976e-08 4.200238972023089356e-08 +4.395809532154282574e-07 2.440965279830963197e-07 7.919627997888279611e-07 7.740279901352539210e-07 -6.242996184514541506e-07 -7.046246406846249833e-08 -6.821253276055609768e-08 4.183721561942336736e-08 +4.326975607881604449e-07 2.269861272472829600e-07 7.953295276532445080e-07 7.600368109714979180e-07 -6.029196550458581727e-07 -7.052164880536016511e-08 -7.113790829227308126e-08 4.231453818192607757e-08 +4.462047077792745865e-07 2.450736314259643984e-07 7.862665174085023684e-07 7.654468033858592534e-07 -6.160424880440258891e-07 -6.966177989993342157e-08 -6.928925672650816081e-08 4.189376172638458291e-08 +4.354073319629619118e-07 2.429588202869715936e-07 7.924883724699147100e-07 7.667203621527438257e-07 -6.238183572776254834e-07 -6.958363914178252595e-08 -6.833383586300379846e-08 4.184981466943890537e-08 +4.320974308086660665e-07 2.406316276252371886e-07 7.920283515125773618e-07 7.671065062716200895e-07 -6.014399229264774901e-07 -6.976366360503069462e-08 -6.938326895734040623e-08 4.172356704576993605e-08 +4.426112460008640110e-07 2.518995091963610222e-07 7.909358982862796759e-07 7.832257932462757213e-07 -6.064200115045205506e-07 -6.946537319690417415e-08 -6.846848630952151314e-08 4.081728482201938142e-08 +3.940290877636466419e-07 2.852765508572484322e-07 6.496649978457568690e-07 7.273100075487677564e-07 -6.271163276622521113e-07 -6.618842304444628969e-08 -6.541315486063779949e-08 4.098245561919994292e-08 +4.352355943904607780e-07 2.402761049081781187e-07 7.900921849744874614e-07 7.667437079757941803e-07 -6.038586691434851029e-07 -6.929454092697857543e-08 -7.080294050999132074e-08 4.166867766934257447e-08 +4.414189028955047043e-07 2.365712470394895269e-07 7.991861828261072816e-07 7.727284992133379197e-07 -6.342577780903252140e-07 -6.970733625469811349e-08 -6.886904637139337568e-08 4.179716116760231864e-08 +3.905583330873879252e-07 2.385648942447208996e-07 7.936433319288584124e-07 7.743507993250012301e-07 -6.232898729488379731e-07 -6.988697076534603554e-08 -7.007713498021374657e-08 4.203598473073582805e-08 +4.614088728796431713e-07 2.554149804003383117e-07 7.818392622691902351e-07 7.418347387980942962e-07 -5.841389602736766903e-07 -6.968679179556443626e-08 -7.019038428569703832e-08 4.149596766480534538e-08 +4.353043248619659814e-07 2.426252892614215320e-07 7.854791214870495605e-07 7.666847035872225253e-07 -6.177479309085333010e-07 -6.995888290706444209e-08 -6.823957027942585552e-08 4.190894175353447863e-08 +4.298976988316351776e-07 2.609651867962838095e-07 8.863314861133560505e-07 7.841706512739445296e-07 -6.096197816910936805e-07 -6.837116073735803131e-08 -6.878240162993642975e-08 4.034883496271640540e-08 +4.268284096255953111e-07 2.350372291688464880e-07 8.239653057499644551e-07 7.815078223060276589e-07 -6.440753099191167327e-07 -6.845755432728797223e-08 -6.705784792981610253e-08 4.106917041063522996e-08 +4.269627780213431905e-07 2.407161864491803372e-07 8.095070300799150441e-07 7.611516072528147865e-07 -6.312925628403599287e-07 -7.044201689066460189e-08 -6.918866078233905477e-08 4.236219385888224772e-08 +4.231124151358618154e-07 2.363779391979789873e-07 8.385452597649726687e-07 7.685639781836781669e-07 -5.796283972437584184e-07 -6.872504903586651898e-08 -7.249515599771912399e-08 4.143668175277871743e-08 +4.077910078687092888e-07 2.392405977686243368e-07 7.936036514843196964e-07 7.712477477823091553e-07 -6.102884756912327983e-07 -6.967052796574975697e-08 -6.877649338922693372e-08 4.182071345779602826e-08 +4.326907458719595333e-07 2.416736838927779001e-07 7.661266527081677951e-07 7.744388861217569368e-07 -6.015798806625006314e-07 -6.952219360578409776e-08 -6.899974152595741510e-08 4.156019524283829982e-08 +4.358027553474181993e-07 2.374879353508360618e-07 7.953372187911406776e-07 7.735993274535236606e-07 -6.214025829557583494e-07 -6.984648973908658134e-08 -6.879278346556261305e-08 4.185344802566026244e-08 +4.197028591674680761e-07 2.371299853559294433e-07 8.036679810846058107e-07 7.762195174658077102e-07 -6.245297306414219143e-07 -6.928962615795788067e-08 -6.840443880793631080e-08 4.146768259025279406e-08 +4.229864822074921567e-07 1.960711361843128866e-07 8.919207786568958338e-07 7.731204884112018326e-07 -6.312311710461727001e-07 -6.850350603573388205e-08 -7.032940009941104489e-08 4.091592626471146449e-08 +4.355020357050093702e-07 2.425779130330551353e-07 7.712909186167022571e-07 7.700585200523088699e-07 -6.118367523325885737e-07 -6.951275900391911003e-08 -6.862321803683741172e-08 4.176347162133015533e-08 +4.359720226817175087e-07 2.380711843860341214e-07 7.855694500276127209e-07 7.728285640370409605e-07 -6.398284981771862002e-07 -6.976561806762883914e-08 -6.868645025060177970e-08 4.157277303813900331e-08 +4.249627392642030208e-07 2.396179059293910144e-07 7.889553131001818525e-07 7.709984337046642206e-07 -6.300764415128815151e-07 -6.944866643036602684e-08 -6.814558965936016995e-08 4.173893392828164049e-08 +4.259722255132177590e-07 2.391952812840316993e-07 7.926974249769973652e-07 7.705077783117301692e-07 -6.228189374476000256e-07 -7.004604948854588936e-08 -6.850381174948850581e-08 4.193336992981463939e-08 +4.412388005086485130e-07 2.422012130183127906e-07 7.964856026132894291e-07 7.748062830025543376e-07 -6.186165888373809283e-07 -6.889949690576339248e-08 -6.867574460841538514e-08 4.143982962682742382e-08 +4.305513111288322737e-07 2.408373863820880642e-07 8.047987656244869785e-07 7.639868354797966324e-07 -6.192574630385369382e-07 -6.972131324395318153e-08 -6.893006202813925084e-08 4.185859049991106945e-08 +4.857738005453178082e-07 2.398098729118023674e-07 7.974040927028972690e-07 7.803102242202110921e-07 -6.242925758850731546e-07 -6.954739212086868978e-08 -6.923538938410647160e-08 4.157509511742497213e-08 +3.953355279960367549e-07 2.422504045632450123e-07 8.264578549921366272e-07 7.747119655693466035e-07 -5.978337660496791208e-07 -6.910516450246840975e-08 -6.903605740662559628e-08 4.112400546508405613e-08 +4.373629190388445017e-07 2.499531882871402601e-07 7.797111300208140957e-07 7.723801580119115356e-07 -6.078609732143302795e-07 -6.986821593594661750e-08 -6.945066075840077140e-08 4.187566205357388962e-08 +4.156111345983488234e-07 2.330963182864734782e-07 7.795349803260661326e-07 7.732283747469220973e-07 -6.347375341185906803e-07 -7.207771348893604070e-08 -6.846827651280806313e-08 4.267923763025501517e-08 +4.183642757837102910e-07 2.518500047877241072e-07 8.334385817999570975e-07 7.658564648962665136e-07 -6.489139524367448463e-07 -6.966220637084591175e-08 -6.953293342449360536e-08 4.183494449848185978e-08 +4.354941656853671386e-07 2.375940619309799866e-07 7.460272655843276331e-07 7.593016765630052452e-07 -5.939594872014339091e-07 -7.067831582976296172e-08 -7.098811424268342633e-08 4.251326457925834015e-08 +4.301995443376489994e-07 2.397227126988529202e-07 7.985273008913189967e-07 7.720459364281608177e-07 -6.279284617263702065e-07 -6.945222395670014961e-08 -6.864613867479353788e-08 4.172410896635030784e-08 +4.403039846856102701e-07 2.400474036361059523e-07 7.829782835334160927e-07 7.595966341849838080e-07 -6.223754742176537301e-07 -7.077233165726085647e-08 -6.916130286566304322e-08 4.205606796476470460e-08 +4.379237856011844521e-07 2.418072254712247159e-07 8.079771413613965775e-07 7.691654549793462945e-07 -6.120842188958305817e-07 -6.948753118129656230e-08 -6.798548610717421760e-08 4.168268395194737285e-08 +3.895462257972829520e-07 2.086566268529627934e-07 4.944287139457130840e-07 7.465212336523136415e-07 -5.645026603896412636e-07 -6.911080924500934689e-08 -7.323806807524846705e-08 4.365003058201830143e-08 +4.356796777132310045e-07 2.364208121134290435e-07 7.898153484961062712e-07 7.688099838171538118e-07 -6.048421315505450081e-07 -7.082751511475506243e-08 -7.090553279827121543e-08 4.250128437901204810e-08 +4.422957512083593340e-07 2.404976245596449649e-07 7.938663893415257800e-07 7.694106323973269778e-07 -6.164678140480879383e-07 -6.944322052369404039e-08 -6.837593665067572396e-08 4.184890588758441721e-08 +4.374133834098762127e-07 2.389191584527039461e-07 7.923734279648181572e-07 7.695921700436172020e-07 -6.116946504954339914e-07 -6.999166651760388929e-08 -6.920060116308700296e-08 4.178367390340307307e-08 +4.270763101299284402e-07 2.379402411958150907e-07 7.737567105885467531e-07 7.802812163886841629e-07 -6.103620774277991627e-07 -6.870906631777966790e-08 -6.767170191031685601e-08 4.061876125708897304e-08 +4.126327836651112277e-07 2.489216265270095568e-07 8.185828606731916774e-07 7.685476075934150152e-07 -6.286467544935777305e-07 -6.864594812290589813e-08 -6.760824037864686469e-08 4.112214973168812358e-08 +5.440103263506284186e-07 2.409761060750651060e-07 8.143877690235905911e-07 7.786390002095498780e-07 -6.318992218541765785e-07 -6.929829845478972272e-08 -6.967246100956536589e-08 4.167992664418576462e-08 +4.082361117209673752e-07 2.464537609600663912e-07 7.962716394751090773e-07 7.657018691898577079e-07 -6.328131557770066919e-07 -7.034784308959005471e-08 -6.653073699016915117e-08 4.175262579750209311e-08 +4.487663154093488824e-07 2.127864868445212561e-07 8.333987600921203254e-07 7.723802253686793032e-07 -6.236572611714607811e-07 -7.083854033062532385e-08 -6.913867748816453040e-08 4.199496082794633728e-08 +4.260229361263368785e-07 2.379344145707607748e-07 7.881423105255345813e-07 7.677052540644782385e-07 -6.137049694709113240e-07 -6.994240661087912487e-08 -6.947061779984017656e-08 4.212314867834996242e-08 +3.597030943801225243e-07 2.084007039878299624e-07 8.386076868512133064e-07 5.865510601732001870e-07 -6.799663470442227997e-07 -6.525059307906238524e-08 -6.619971878954502623e-08 4.313835743407120911e-08 +4.420705324276784343e-07 2.441338817332951094e-07 7.901458002964272028e-07 7.713296170630648844e-07 -6.169627013926467725e-07 -6.938612171450642273e-08 -6.904323989540785748e-08 4.161390823112186169e-08 +4.351394676433425831e-07 2.421491387275135057e-07 7.990103794247729983e-07 7.691587005767136938e-07 -6.231279130927585202e-07 -6.927170843822238113e-08 -6.826872917605243348e-08 4.164391126728461508e-08 +4.499219853457555624e-07 2.341288537738325066e-07 7.797191748160541115e-07 7.715835745118754291e-07 -6.067316146120031807e-07 -7.072928877903889619e-08 -7.108042884087830263e-08 4.215220078092916934e-08 +3.287522369638606419e-07 2.498026848451905137e-07 3.772212388502486845e-07 7.915482747317223847e-07 -4.214579177824433807e-07 -6.980418340915286909e-08 -7.105857804240422201e-08 4.030615432201546324e-08 +4.766681001369071885e-07 2.462708008651178794e-07 7.829906593185914919e-07 7.681032905935161704e-07 -6.179081199937752228e-07 -7.000059076419124660e-08 -6.854146438482623913e-08 4.183813317494766049e-08 +4.537196146917507299e-07 2.484404391947775796e-07 8.168493400879236084e-07 7.710104672877389649e-07 -6.297616728143828706e-07 -6.975617305184906877e-08 -6.929589724769670410e-08 4.168757573309443210e-08 +4.221918187377379843e-07 2.442362731325902512e-07 7.703170943583542540e-07 7.631139554607784676e-07 -6.198915719101011232e-07 -6.924902085927676217e-08 -6.980734451581990528e-08 4.187111547380076168e-08 +4.536093972001422716e-07 2.419546930613943209e-07 8.016730515164741650e-07 7.726440049022196662e-07 -6.254704458163415832e-07 -6.990121510560453160e-08 -6.678003823694922030e-08 4.155212925842526413e-08 +4.311837191864365753e-07 2.377164962741038671e-07 8.090156250538221006e-07 7.675981565051317500e-07 -6.243115521435400843e-07 -6.991351857035574801e-08 -6.918082456822039210e-08 4.206334953409249521e-08 +4.006654382198302710e-07 2.369310258650866643e-07 7.900544156526814343e-07 7.867421811632521933e-07 -6.074748496340336350e-07 -6.948806321817928603e-08 -6.772450631824511523e-08 4.153397691670188909e-08 +4.343756325041337739e-07 2.411825638161091238e-07 7.913020451519311931e-07 7.732067188807485437e-07 -6.107111659658437025e-07 -6.893172147468249656e-08 -6.993361824519483601e-08 4.146585026884605454e-08 +4.360954335276300552e-07 2.362968853869360535e-07 7.832339594323662947e-07 7.701738647099044620e-07 -5.831707633473210047e-07 -6.970200710939630027e-08 -7.338004543367234945e-08 4.191403915491362064e-08 +4.428959073383497503e-07 2.399825850735279282e-07 7.792084800972537215e-07 7.685932602077272558e-07 -6.054469031641732499e-07 -6.972612332246664207e-08 -6.930233017112774725e-08 4.169839179845698693e-08 +7.227191013263688061e-07 1.703245220229118157e-07 8.120748035235609090e-07 7.711405736711179908e-07 -5.718393249320335507e-07 -6.967004833858883751e-08 -7.007440882235615810e-08 4.247400232611325096e-08 +4.451069260492197738e-07 2.520696516072245902e-07 7.877778409060701679e-07 7.666852362033133400e-07 -6.243652712794745205e-07 -6.900563851894975646e-08 -6.882684179305148832e-08 4.130833146235240289e-08 +4.651854275228677009e-07 2.376376824607763261e-07 8.011476308341767104e-07 7.639060279884899410e-07 -6.426408630079228250e-07 -7.016466761481792809e-08 -6.830340575349622349e-08 4.259477882056371752e-08 +4.375668915647867113e-07 2.397610060295838108e-07 7.942360048928054500e-07 7.707214694624741035e-07 -6.220941476926851104e-07 -6.959532526330362928e-08 -6.856728031849626423e-08 4.183458549868966215e-08 +5.977269036417805405e-07 2.508284095644978839e-07 8.267150675971193500e-07 7.673336757716309409e-07 -6.111189982690955386e-07 -6.616868186971610180e-08 -6.607190057479624586e-08 3.980616454667557889e-08 +4.375331235133106752e-07 2.347865168942652658e-07 7.813046622900232460e-07 7.852795855807399547e-07 -6.168678218097331378e-07 -7.072184614069736075e-08 -6.925703142698933782e-08 4.204111877992597812e-08 +4.164418586317611702e-07 2.342200002033817317e-07 8.024965006186897545e-07 7.671582122847736095e-07 -6.250650665337457087e-07 -6.973893305614916074e-08 -7.029322887464303114e-08 4.198414076616045059e-08 +4.234944961199447816e-07 2.471711326309026300e-07 8.011755188295802292e-07 7.689582364961511156e-07 -6.157163499446466136e-07 -6.885787245073988008e-08 -6.899209398888340411e-08 4.115386595287777978e-08 +4.340406264850038478e-07 2.348975647143953137e-07 7.765946320699842065e-07 7.790722947795597427e-07 -5.843611279860693671e-07 -7.017341797999996063e-08 -6.880836157608645921e-08 4.167898957803428717e-08 +4.466948625270988023e-07 2.316363965885518214e-07 8.238193006369677999e-07 7.760140073742336105e-07 -6.409296468048070269e-07 -6.972419332829377896e-08 -6.808944739571440582e-08 4.183125590608235137e-08 +4.399739409517525176e-07 2.407856869454149725e-07 7.904340828103696047e-07 7.697107820045693782e-07 -6.116005384908655886e-07 -6.992557612629609067e-08 -6.912285256542666178e-08 4.203640850099816169e-08 +3.814005217181779522e-07 2.506514083672646549e-07 7.919734899746789803e-07 7.827214547042922691e-07 -5.758261898922209719e-07 -6.624184938967349723e-08 -6.658921074209098710e-08 3.982047863312780822e-08 +4.232905762938639980e-07 2.417169543876350314e-07 7.522675383892508823e-07 7.700356882502104692e-07 -6.234273779227920297e-07 -7.045276216215259849e-08 -6.737918332842633098e-08 4.175506726819954655e-08 +4.801476145953123265e-07 2.623558944695305950e-07 7.823355938321220482e-07 7.697177095087242697e-07 -6.460361837677698317e-07 -6.803279525556672324e-08 -6.230413173139660353e-08 4.076155632419779288e-08 +4.544830176910705866e-07 2.373150271576160462e-07 8.137209032357746417e-07 7.762886431374167747e-07 -6.315311710512976955e-07 -6.987506238075780899e-08 -6.958841768375324299e-08 4.174518174042302706e-08 +4.121964691067428285e-07 2.422060385084136039e-07 7.950647595683928618e-07 7.634350965848992366e-07 -6.302669757062486370e-07 -7.009670118591467555e-08 -6.893071364365912046e-08 4.209330500046725753e-08 +3.989164236080398708e-07 2.347814986193491375e-07 7.674626811124299676e-07 7.654980120953262597e-07 -6.084195035864502375e-07 -6.926625717576093684e-08 -6.965210674911597294e-08 4.192097748705750837e-08 +4.686657200135267582e-07 2.371410568678798942e-07 8.069938222779210351e-07 7.657382592339794156e-07 -6.178682321857905414e-07 -6.920216797436243076e-08 -6.918162646559424836e-08 4.152501045083535030e-08 +3.999870619780445422e-07 2.415296328433217862e-07 7.611183788694658418e-07 7.723214298240095516e-07 -6.129134693278788681e-07 -6.916505149729599205e-08 -6.830019126072035509e-08 4.130033372384712214e-08 +3.955955344786115939e-07 2.353970914804710345e-07 9.135697010831058118e-07 7.619171266806717983e-07 -8.242366129662157962e-07 -7.220535138141785726e-08 -6.259784081547110109e-08 4.400006300415099794e-08 +4.067513191263003743e-07 2.339919538771540841e-07 7.805856627082214697e-07 7.733500673357700059e-07 -6.204019958819640110e-07 -7.025046117649591288e-08 -7.027992167811985637e-08 4.224071407021021922e-08 +4.307973358750686133e-07 2.398706511582814691e-07 8.103589600855989239e-07 7.645005127709722484e-07 -6.039666519556157971e-07 -6.837167359690402864e-08 -6.897180146429529651e-08 4.112528371980280190e-08 +4.434395804951636727e-07 2.416120261275363164e-07 8.266836703098514417e-07 7.683641239496467604e-07 -6.406077979688843206e-07 -6.949702738158839125e-08 -6.726904693021690291e-08 4.157094315282664793e-08 +4.269879339712067664e-07 2.504613087266038815e-07 7.670226615486674576e-07 7.610859100198381810e-07 -6.462663774413680793e-07 -6.914785628804243295e-08 -6.768389034678219436e-08 4.166400614361949556e-08 +4.383825077483041373e-07 2.389909426160813414e-07 7.984492817797506771e-07 7.655943034187369913e-07 -6.161327252573330933e-07 -6.931638993744163591e-08 -6.808957304738968927e-08 4.176391301110731974e-08 +5.176598392486330116e-07 2.534501003930162749e-07 8.020848945558878822e-07 7.650835794855073527e-07 -6.155244403431961587e-07 -6.916686417110778520e-08 -6.911366198292869695e-08 4.154322256461693734e-08 +4.041778844517738209e-07 2.353098889978786342e-07 8.099657246795112638e-07 7.680588934133897360e-07 -6.261600197897386389e-07 -6.924318148407060906e-08 -6.954160480092402827e-08 4.145940195195361445e-08 +5.117467456847324989e-07 2.370092763333616188e-07 7.900761894610020069e-07 7.681245127169054801e-07 -6.134597618674943734e-07 -7.035556804397311269e-08 -7.098078914123347394e-08 4.216072865138864748e-08 +4.160071304408778921e-07 2.378218117485849544e-07 8.022212360965836496e-07 7.808603482759733503e-07 -6.315367706773027765e-07 -6.938063132558099152e-08 -6.817779809523976113e-08 4.163600846766017037e-08 +4.356768782020345087e-07 2.398877897199886851e-07 7.786227886668586851e-07 7.749297273990085617e-07 -6.176011411972227622e-07 -7.011059493513983995e-08 -6.849425521071669365e-08 4.189077570996942956e-08 +4.308598383233507805e-07 2.376254567127901879e-07 7.900340416950577486e-07 7.714285035479523790e-07 -6.148384165150146036e-07 -6.962215725082747277e-08 -6.858732354818692307e-08 4.180627378890568342e-08 +4.155961153991064977e-07 2.416140528282541595e-07 7.884172805375148742e-07 7.634775051992034154e-07 -6.308553301065552882e-07 -6.944757405535441449e-08 -6.854935825972282962e-08 4.169264419190580999e-08 +4.460786511249578059e-07 2.513485519128253005e-07 7.957846762228023465e-07 7.480476228831585132e-07 -6.228624753749025380e-07 -6.950033353841416084e-08 -6.846817503457495938e-08 4.183038077227703546e-08 +4.250000352154048479e-07 2.505435302659958864e-07 7.574670604907738493e-07 7.694542873955345132e-07 -6.118075585254074495e-07 -6.838513354885190504e-08 -6.710282410267156235e-08 4.126573182429798474e-08 +4.337077378826610394e-07 2.419244958667117844e-07 7.843569270869123437e-07 7.872044814986191896e-07 -6.234695577890216110e-07 -6.949013137682651635e-08 -6.783023488874846730e-08 4.138431851395165088e-08 +3.027705814396127935e-07 2.576004063961948114e-07 8.458456693943872021e-07 7.701618670199123734e-07 -6.483307260212815663e-07 -7.008884175293379935e-08 -6.769787063169103980e-08 4.174256400962850007e-08 +4.097366087265283680e-07 2.285274302765781116e-07 8.811123614933118509e-07 6.773304183850204923e-07 -5.797697231611951449e-07 -6.451462609194232836e-08 -7.138246648855104776e-08 4.101498430868842089e-08 +4.428889929721520091e-07 2.386993231866593462e-07 8.065631256090262158e-07 7.797432665582136199e-07 -6.443034530376437832e-07 -6.892247387542592368e-08 -6.793885992615043206e-08 4.131635141841487383e-08 +4.353644574896620409e-07 2.368358249029361829e-07 7.998351236599979986e-07 7.771377870533689010e-07 -6.285528137607205416e-07 -6.960480176238566226e-08 -6.886086899553185978e-08 4.178118462309211462e-08 +3.711884469441154745e-07 3.197004375075418055e-07 8.342872031072270191e-07 7.793301223574494889e-07 -5.663202341759901596e-07 -5.536832316630600246e-08 -5.462769239450116708e-08 3.238782770860376189e-08 +3.990552356595259530e-07 2.090788675229238993e-07 8.538891579857254248e-07 6.994500152171143252e-07 -5.948457031509729154e-07 -6.775609069015084862e-08 -7.107428755735491931e-08 4.262064893353395219e-08 +4.415560419177344994e-07 2.430510676335358066e-07 7.952084591849860732e-07 7.705446192869128661e-07 -6.471930442653179213e-07 -6.939145240831972410e-08 -6.644079614514679192e-08 4.138067431802051892e-08 +4.144963064396755921e-07 2.563923867569677300e-07 8.154399586588201697e-07 7.403723267212376741e-07 -6.177189030614813500e-07 -6.999810349982014522e-08 -6.695088837472546257e-08 4.247702859924930677e-08 +4.303182952503930114e-07 2.476637456890288124e-07 7.941823718873176818e-07 7.634722224820934675e-07 -6.337171271124563758e-07 -7.016277992714322902e-08 -7.042750345715852866e-08 4.204904897170025263e-08 +4.080167889503699265e-07 2.510141138821329469e-07 7.780811477944243875e-07 7.515477838879247676e-07 -5.774274497398316241e-07 -6.909375199370017610e-08 -6.874180181454435054e-08 4.229564858500549935e-08 +4.402872932970411746e-07 2.503538042828364739e-07 7.732626932495127768e-07 7.665858706184411858e-07 -6.278029594433110880e-07 -7.024323784357246215e-08 -6.896844737236839518e-08 4.219753921923880203e-08 diff --git a/inst/extdata/sldsc_trait/sumstats2.parquet.results b/inst/extdata/sldsc_trait/sumstats2.parquet.results new file mode 100644 index 00000000..7f2e5e11 --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats2.parquet.results @@ -0,0 +1,9 @@ +Category Prop._SNPs Prop._h2 Prop._h2_std_error Enrichment Enrichment_std_error Enrichment_p Coefficient Coefficient_std_error Coefficient_z-score +ANNOT_0 1.6443e-02 3.5532e-01 2.5211e-01 2.1610e+01 1.5333e+01 3.8137e-01 4.3326e-07 5.3782e-07 8.0557e-01 +Coding_UCSC_common_1 5.2671e-03 1.2561e-01 8.0296e-02 2.3848e+01 1.5245e+01 6.3180e-03 2.4099e-07 1.7209e-07 1.4004e+00 +Coding_UCSC_lowfreq_1 1.1581e-02 2.9859e-01 2.9156e-01 2.5783e+01 2.5176e+01 3.5234e-01 7.9606e-07 6.8414e-07 1.1636e+00 +Conserved_LindbladToh_common_1 8.8296e-03 3.3881e-01 2.0268e-01 3.8372e+01 2.2955e+01 1.8981e-03 7.6880e-07 2.6219e-07 2.9323e+00 +Conserved_LindbladToh_lowfreq_1 2.0367e-02 -3.7716e-01 4.1302e-01 -1.8518e+01 2.0279e+01 2.2592e-01 -6.1833e-07 4.3374e-07 -1.4256e+00 +Repressed_Hoffman_common_1 1.7496e-01 3.9068e-02 1.4954e-01 2.2330e-01 8.5474e-01 2.6040e-01 -6.9337e-08 1.9030e-08 -3.6435e+00 +Repressed_Hoffman_lowfreq_1 2.7381e-01 -4.6130e-01 3.8070e-01 -1.6848e+00 1.3904e+00 3.4479e-03 -6.8686e-08 2.7824e-08 -2.4686e+00 +base_1 1.0000e+00 1.0002e+00 1.7396e-04 1.0002e+00 1.7396e-04 NA 4.1626e-08 1.1791e-08 3.5304e+00 diff --git a/inst/extdata/sldsc_trait/sumstats3.parquet.log b/inst/extdata/sldsc_trait/sumstats3.parquet.log new file mode 100644 index 00000000..52e096e9 --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats3.parquet.log @@ -0,0 +1,41 @@ +********************************************************************* +* LD Score Regression (LDSC) +* Version 1.0.0 +* (C) 2014-2015 Brendan Bulik-Sullivan and Hilary Finucane +* Broad Institute of MIT and Harvard / MIT Department of Mathematics +* GNU General Public License v3 +********************************************************************* +Call: +./ldsc.py \ +--out /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats3.parquet \ +--h2 data/polyfun_new/example_data/sumstats3.parquet \ +--ref-ld-chr output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations. \ +--w-ld-chr data/polyfun_new/example_data/weights. \ +--overlap-annot \ +--print-coefficients \ +--print-delete-vals \ +--not-M-5-50 + +Beginning analysis at Sat Jun 6 13:20:20 2026 +Reading summary statistics from data/polyfun_new/example_data/sumstats3.parquet ... +Read summary statistics for 15954873 SNPs. +Reading reference panel LD Score from output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations.[1-22] ... +Read reference panel LD Scores for 3475 SNPs. +Reading regression weight LD Score from data/polyfun_new/example_data/weights.[1-22] ... +Read regression weight LD Scores for 182454 SNPs. +After merging with reference panel LD, 23 SNPs remain. +After merging with regression SNP LD, 23 SNPs remain. +WARNING: number of SNPs less than 200k; this is almost always bad. +Removed 0 SNPs with chi^2 > 487.511 (23 SNPs remain) +Printing block jackknife delete values to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats3.parquet.delete. +Printing partitioned block jackknife delete values to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats3.parquet.part_delete. +Total Observed scale h2: -0.0188 (0.0147) +Categories: ANNOT_0 Coding_UCSC_common_1 Coding_UCSC_lowfreq_1 Conserved_LindbladToh_common_1 Conserved_LindbladToh_lowfreq_1 Repressed_Hoffman_common_1 Repressed_Hoffman_lowfreq_1 base_1 +Lambda GC: 1.4619 +Mean Chi^2: 0.9606 +Intercept: 1.4454 (0.618) +Ratio: NA (mean chi^2 < 1) +Reading annot matrix from output/sldsc_ldscore/protocol_example_single_1/protocol_example_single_1.,data/polyfun_new/example_data/annotations.[1-22] ... +Results printed to /restricted/projectnb/xqtl/jaempawi/xqtl_protocol/toy_example/output/sldsc_heritability/protocol_example_single_1/sumstats3.parquet.results +Analysis finished at Sat Jun 6 13:21:16 2026 +Total time elapsed: 55.43s diff --git a/inst/extdata/sldsc_trait/sumstats3.parquet.part_delete b/inst/extdata/sldsc_trait/sumstats3.parquet.part_delete new file mode 100644 index 00000000..16583536 --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats3.parquet.part_delete @@ -0,0 +1,23 @@ +-1.337491644224899399e-06 -1.342997300785304146e-07 4.613621606226517460e-07 4.841972756673158720e-07 -2.125984797634708330e-06 2.969307596958648231e-08 -6.069382498286234090e-08 -6.390369473482388653e-09 +-1.042250875196413762e-06 -1.509016829934074087e-07 9.614969912590531858e-07 2.472819317987935655e-07 -3.712167962514336027e-06 3.019005754517598391e-08 -6.221780382529201536e-08 -3.607799519783960093e-09 +-1.349081476475052143e-06 -1.502572437968281677e-07 8.488802264436368821e-07 2.643130838073767464e-07 -3.820653041856169809e-06 2.778173925927634484e-08 -5.938482996128325966e-08 -2.469206933955650657e-09 +-1.658825202415447053e-06 -1.569566433615256221e-07 1.069141367888299214e-06 2.870153766144226588e-07 -4.349980714958885330e-06 2.903549499899700105e-08 -5.308297047364897553e-08 -3.981750606668717289e-09 +-1.585389106396689852e-06 -1.360616541744481096e-07 8.313682153086127445e-07 3.852841909425004676e-07 -4.676926204328846816e-06 1.176405662797375129e-08 6.741279840131333596e-08 -1.757185808148742654e-09 +-1.215075843883514187e-06 -1.679760091449235266e-07 1.108248737122411625e-06 3.129498442990974680e-07 -4.126377035505225315e-06 4.215097512537345598e-08 -1.512283097804666316e-07 -4.170355128935954232e-09 +-1.260323439190421722e-06 -1.592077187806113645e-07 1.004890817362022033e-06 2.603207280985288161e-07 -3.978627773759339799e-06 3.416756768741751893e-08 -1.013703930378287925e-07 -3.766141302257464384e-09 +-1.333909099569529415e-06 -5.603617681526993749e-09 4.772709638556230102e-07 2.548281766342094213e-07 -3.704374209559061219e-06 3.279171078177363161e-08 -4.051535628981501966e-08 -6.905152608824172818e-09 +-1.767722271731306047e-06 -1.662051150693471088e-07 1.331686469544002713e-06 2.492224206758025318e-07 -3.836062600143032804e-06 2.538418463819044264e-08 -1.118605190884487193e-08 -2.394188683515550581e-09 +-1.367255405048451697e-06 -1.127967484063216915e-07 6.367926508810680058e-07 1.721044284904406605e-07 -3.328586284804915501e-06 3.874150682233989713e-08 -1.663736704357271405e-07 7.940653796184140092e-11 +-1.366255658040798221e-06 -1.451104742731952100e-07 9.450821667663338538e-07 2.724272951019491432e-07 -3.963481086860401285e-06 2.962130542301561804e-08 -5.691332843940388696e-08 -3.571192315677443575e-09 +-1.337891589976789519e-06 -1.286153633910781927e-07 1.218095105240499931e-06 2.595213328221688757e-07 -3.812692300622642864e-06 3.656362071416135747e-08 -5.388579548451638619e-08 -8.184789647570153760e-09 +-4.901838533219738065e-07 -1.655268326037131477e-07 1.351955467964851695e-06 3.157605340597339757e-07 -4.685909413132030041e-06 2.316815092067441610e-08 5.061674337094153235e-09 -2.986047889944182630e-09 +-1.772900769659287814e-06 -5.420883644800451366e-08 1.810557000566925244e-07 -2.532098606827101542e-08 -1.161534824976643098e-06 3.086064193535549688e-08 -8.275505959281791633e-08 -1.805488119223560133e-09 +-1.352164576424419393e-06 -1.448944764647148656e-07 9.219765876392754673e-07 2.690125393863531646e-07 -3.877328082073467544e-06 2.948779680780127319e-08 -5.478437813383635814e-08 -3.714718265832326291e-09 +-1.275147285914893605e-06 -1.446295518947711728e-07 9.936210138802514567e-07 2.895619859771357861e-07 -4.931074158403805764e-06 1.700775885261448553e-08 1.556199942415600236e-07 -1.240552336155166185e-09 +-1.332083844077644303e-06 -1.470807235461124156e-07 1.038155155799505215e-06 2.694707569856160935e-07 -3.894468560070564650e-06 3.012027024348048204e-08 -5.886891053895719808e-08 -3.964059693375356939e-09 +-1.513527415206473195e-06 -1.476149617593364030e-07 3.187228301023966814e-07 2.685093862983752533e-07 -3.815948986184896911e-06 3.078517941264865201e-08 -5.897725891100759428e-08 -4.519757684013051974e-09 +-1.413455308171493869e-06 -1.660574232386599653e-07 8.980087512919496000e-07 3.355137570925351081e-07 -4.455916146996528223e-06 2.349109508525209156e-08 -1.004477413353172893e-07 -2.294248080008415054e-09 +-1.321310275120020184e-06 -1.529333054690542668e-07 1.124675032526910888e-06 2.562963111250904584e-07 -3.777618203509784358e-06 3.327538760361892476e-08 -6.132313759295204080e-08 -5.669361000459379987e-09 +-1.462959733948555514e-06 -1.312469478908625383e-07 8.692286414105295550e-07 2.723534664271295456e-07 -3.772912753190990161e-06 2.975149274540727843e-08 -5.485953952787794542e-08 -3.680693650486622868e-09 +-1.392676163532372124e-06 -1.373697232774311559e-07 8.856848199345199476e-07 2.564379221680695658e-07 -3.695213289969318279e-06 2.989437215187026353e-08 -5.702579552631445152e-08 -3.594852461978655779e-09 +-1.030812604645125624e-06 -2.075817457194909218e-07 1.417047283595439006e-06 2.909460032715541582e-07 -5.359026917220635120e-06 3.390455966854070512e-08 -7.809010070239526736e-08 -6.450729375648331263e-09 diff --git a/inst/extdata/sldsc_trait/sumstats3.parquet.results b/inst/extdata/sldsc_trait/sumstats3.parquet.results new file mode 100644 index 00000000..0faaefdb --- /dev/null +++ b/inst/extdata/sldsc_trait/sumstats3.parquet.results @@ -0,0 +1,9 @@ +Category Prop._SNPs Prop._h2 Prop._h2_std_error Enrichment Enrichment_std_error Enrichment_p Coefficient Coefficient_std_error Coefficient_z-score +ANNOT_0 1.6443e-02 2.1566e-01 3.1289e-01 1.3116e+01 1.9029e+01 3.1339e-01 -1.3607e-06 1.2055e-06 -1.1288e+00 +Coding_UCSC_common_1 5.2671e-03 9.6377e-03 1.2314e-02 1.8298e+00 2.3378e+00 6.4357e-01 -1.4431e-07 1.8301e-07 -7.8849e-01 +Coding_UCSC_lowfreq_1 1.1581e-02 7.3524e-02 1.5360e-01 6.3487e+00 1.3263e+01 6.3295e-01 9.2611e-07 1.4601e-06 6.3429e-01 +Conserved_LindbladToh_common_1 8.8296e-03 -1.1455e-02 4.9731e-02 -1.2973e+00 5.6323e+00 5.8975e-01 2.6652e-07 3.9973e-07 6.6676e-01 +Conserved_LindbladToh_lowfreq_1 2.0367e-02 7.2945e-01 9.7767e-01 3.5816e+01 4.8003e+01 3.3196e-01 -3.8835e-06 3.9244e-06 -9.8959e-01 +Repressed_Hoffman_common_1 1.7496e-01 4.0020e-02 1.2505e-01 2.2874e-01 7.1472e-01 4.8102e-01 2.9668e-08 2.9876e-08 9.9304e-01 +Repressed_Hoffman_lowfreq_1 2.7381e-01 4.1264e-01 6.4483e-01 1.5071e+00 2.3550e+00 8.0906e-01 -5.6984e-08 2.9704e-07 -1.9184e-01 +base_1 1.0000e+00 1.0001e+00 2.0907e-04 1.0001e+00 2.0907e-04 NA -3.6493e-09 8.9312e-09 -4.0861e-01 diff --git a/inst/scripts/build_ctwas_examples.R b/inst/scripts/build_ctwas_examples.R new file mode 100644 index 00000000..1ddb0372 --- /dev/null +++ b/inst/scripts/build_ctwas_examples.R @@ -0,0 +1,145 @@ +# ============================================================================= +# Rebuild the bundled cTWAS example objects. +# ----------------------------------------------------------------------------- +# ctwasInputsExample / ctwasEstExample / ctwasFinemapExample are the payloads +# of the granular chain +# +# assembleCtwasInputs -> estCtwasParam -> screenCtwasRegions +# -> finemapCtwasRegions +# +# captured after each step, so a user can enter the chain anywhere without +# re-running what came before. +# +# The payloads carry an `LD_map$LD_file` token that ctwas asserts exists on +# disk and that pecotmr uses as the dispatch key into the cached per-region LD +# panels. Baking an absolute path into the .rda makes that token point at the +# machine that built it -- which is what left the previous objects unusable +# past `screenCtwasRegions` (finemapCtwasRegions failed on +# `all(file.exists(LD_matrix_files))`). Step 3 rewrites the token to the +# portable "pecotmr://extdata/" form the genotype handles already use; +# `.ctwasResolveLdPaths()` resolves it at extraction time on whatever machine +# the package is installed. +# +# Run from the package root: +# Rscript inst/scripts/build_ctwas_examples.R +# ============================================================================= + +devtools::load_all(".", quiet = TRUE) + +# ----------------------------------------------------------------------------- +# 1. Inputs: the bundled chr22 LD panel, GWAS sumstats, and TWAS weights. +# ----------------------------------------------------------------------------- +ldStem <- file.path( + system.file("extdata", "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22" +) +gwasTsv <- system.file( + "extdata", + "manifests", + "protocol_example.twas.gwas_sumstats.chr22.tsv.gz", + package = "pecotmr" +) + +# cTWAS needs at least two LD blocks: its EM cannot converge on one region. +blocks <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), + blockId = c("chr22_1", "chr22_2") +) + +gwasSumStats <- loadGwasSumStatsFromManifest( + manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), + genome = "hg38", + ldSketch = ldStem, + region = "chr22:10000000-19000000", + ldBlocks = blocks +) +gwasByRegion <- summaryStatsQc(gwasSumStats, mafCutoff = 0.0025) + +data(ctwasWeightsExample) + +# ----------------------------------------------------------------------------- +# 2. Run the chain, capturing each payload. +# ----------------------------------------------------------------------------- +ctwasInputsExample <- assembleCtwasInputs( + gwasSumStats = gwasByRegion, + twasWeights = list(ctwasWeightsExample) +) + +ctwasEstExample <- estCtwasParam( + ctwasInputsExample, + thin = 1, + niterPrefit = 3, + niter = 10, + min_group_size = 1, + min_p_single_effect = 0, + fallbackToPrefit = TRUE +) + +# The toy GWAS carries no genome-wide-significant signal, so the default +# screen (min_nonSNP_PIP = 0.5) selects nothing and the example would be an +# empty result. Keep every region so the finemap payload is populated. +screened <- screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) +ctwasFinemapExample <- finemapCtwasRegions(screened) + +# ----------------------------------------------------------------------------- +# 3. Make the LD token portable. +# ----------------------------------------------------------------------------- +asResource <- function(p) { + rel <- sub( + paste0("^.*", .Platform$file.sep, "extdata", .Platform$file.sep), + "", + p + ) + paste0("pecotmr://extdata/", rel) +} + +repointLd <- function(payload) { + if (is.null(payload$LD_map)) { + return(payload) + } + stored <- as.character(payload$LD_map$LD_file) + portable <- vapply(stored, asResource, character(1), USE.NAMES = FALSE) + keyMap <- setNames(portable, stored) + payload$LD_map$LD_file <- portable + payload$LD_map$SNP_file <- portable + # The loader closures dispatch on the same token, so their cache has to be + # re-keyed in step with it or the resolved token finds no panel. + pecotmr:::.ctwasRekeyLdLoaders(payload, keyMap) +} + +ctwasInputsExample <- repointLd(ctwasInputsExample) +ctwasEstExample <- repointLd(ctwasEstExample) +ctwasFinemapExample <- repointLd(ctwasFinemapExample) + +stopifnot( + all(grepl("^pecotmr://", ctwasInputsExample$LD_map$LD_file)), + all(grepl("^pecotmr://", ctwasEstExample$LD_map$LD_file)), + all(grepl("^pecotmr://", ctwasFinemapExample$LD_map$LD_file)) +) + +# ----------------------------------------------------------------------------- +# 4. Verify each payload still drives the step that consumes it, from the +# portable form -- the check the previous objects would have failed. +# ----------------------------------------------------------------------------- +invisible(estCtwasParam( + ctwasInputsExample, + thin = 1, + niterPrefit = 3, + niter = 10, + min_group_size = 1, + min_p_single_effect = 0, + fallbackToPrefit = TRUE +)) +invisible(finemapCtwasRegions( + screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) +)) +invisible(asCtwasResult(ctwasFinemapExample)) +invisible(mergeCtwasBoundaryRegions(ctwasFinemapExample)) + +# ----------------------------------------------------------------------------- +# 5. Save. +# ----------------------------------------------------------------------------- +usethis::use_data(ctwasInputsExample, overwrite = TRUE, compress = "xz") +usethis::use_data(ctwasEstExample, overwrite = TRUE, compress = "xz") +usethis::use_data(ctwasFinemapExample, overwrite = TRUE, compress = "xz") diff --git a/inst/scripts/build_examples.R b/inst/scripts/build_examples.R index 217b2acf..73971cc4 100644 --- a/inst/scripts/build_examples.R +++ b/inst/scripts/build_examples.R @@ -13,7 +13,7 @@ # gwasSumStatsS4Example : GwasSumStats # multiStudyQtlDatasetExample : MultiStudyQtlDataset # -# Re-run: pixi run Rscript data-raw/build_examples.R +# Re-run: pixi run Rscript inst/scripts/build_examples.R # ============================================================================= devtools::load_all(".") diff --git a/inst/scripts/build_h2_examples.R b/inst/scripts/build_h2_examples.R new file mode 100644 index 00000000..b5621baf --- /dev/null +++ b/inst/scripts/build_h2_examples.R @@ -0,0 +1,114 @@ +# ============================================================================= +# Rebuild ldEigenExample / ldScoreExample from a real LD reference. +# ----------------------------------------------------------------------------- +# These two objects feed estimateH2(). The versions they replace were 20 SNPs +# in 2 blocks -- enough to demonstrate the accessors, but far too small to run +# a heritability estimator: every method returned a boundary value near zero, +# and two blocks cannot support the delete-one-block jackknife the standard +# errors come from. +# +# They are now built from the xqtl-protocol MWE's chr22 LD reference: real +# genotype-derived LD over the same de-identified `protocol_example` panel the +# package already ships a slice of, using the LD blocks the protocol defines. +# `buildLdEigen()` / `buildLdScore()` do the work, so this script doubles as a +# worked example of them. +# +# Requires the MWE checkout; set MWE_DIR to point at it: +# MWE_DIR=/path/to/xqtl-protocol Rscript inst/scripts/build_h2_examples.R +# ============================================================================= + +devtools::load_all(".", quiet = TRUE) + +mweDir <- Sys.getenv( + "MWE_DIR", + "/Users/danielnachun/Downloads/fungen_xqtl/xqtl-protocol" +) +metaPath <- file.path( + mweDir, + "input/ld_reference/protocol_example.ld_meta_file.tsv" +) +if (!file.exists(metaPath)) { + stop("Set MWE_DIR to an xqtl-protocol checkout; not found: ", metaPath) +} + +# How many of chr22's LD blocks to keep. All 20 work, but the eigenvectors of +# a real LD block compress poorly, so the pair costs ~2.4 MB at 20 against +# ~1.2 MB at 14 -- and 14 blocks still leaves a usable jackknife. +N_BLOCKS <- 14L + +blocks <- read.delim(metaPath, check.names = FALSE) +names(blocks)[1] <- "chr" +chr22 <- blocks[blocks$chr == "chr22", ] +chr22 <- head(chr22[order(chr22$start), ], N_BLOCKS) +regions <- sprintf("chr22:%d-%d", chr22$start, chr22$end) +message("Loading ", length(regions), " chr22 LD blocks...") + +# One LdData per block: buildLd*() takes the list and gives one LD block per +# element. Loading the whole span at once would instead return a single dense +# matrix, i.e. one block, which no jackknife can work with. +ldList <- lapply(regions, function(r) loadLdMatrix(metaPath, region = r)) +message( + " ", + sum(vapply(ldList, length, integer(1))), + " variants across ", + length(ldList), + " blocks" +) + +ldEigenExample <- buildLdEigen(ldList, genome = "hg38") +ldScoreExample <- buildLdScore(ldList, genome = "hg38") + +stopifnot( + length(ldEigenExample) == length(ldScoreExample), + length(getEigenList(ldEigenExample)) == N_BLOCKS, + length(getLdMatrixList(ldScoreExample)) == N_BLOCKS, + identical(names(ldEigenExample), names(ldScoreExample)) +) + +# The two routes to an LD score must agree, or one of them has drifted. +stopifnot(all.equal( + as.vector(getLdScores(ldScoreExample)[, 1]), + as.vector(computeLdScores(ldEigenExample)[, 1]) +)) + +# ----------------------------------------------------------------------------- +# Confirm every estimator recovers a known h2 on this reference before saving. +# z is simulated under the standard model z ~ N(0, N R diag(v) R + R). +# ----------------------------------------------------------------------------- +M <- length(ldEigenExample) +N <- 1e5 +h2True <- 0.4 +perSnpVar <- rep(h2True / M, M) + +simZ <- function() { + z <- numeric(M) + for (block in getLdMatrixList(ldScoreExample)) { + idx <- block$snpIdx + p <- length(idx) + sigma <- N * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + block$R + sigma <- (sigma + t(sigma)) / 2 + e <- eigen(sigma, symmetric = TRUE) + z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) + } + z +} + +set.seed(1) +recovered <- replicate(5, { + z <- simZ() + c( + sldsc = pecotmr:::sldscUnivariate(z, N, ldScoreExample)$h2, + gldsc = pecotmr:::gldscUnivariate(z, N, ldScoreExample)$h2, + lder = pecotmr:::lderUnivariate(z, N, ldEigenExample)$h2 + ) +}) +message("h2 recovery (true 0.4):") +print(round(rowMeans(recovered), 3)) +stopifnot(all(abs(rowMeans(recovered) - h2True) < 0.15)) + +# HDL is deliberately excluded from that check: it models reference-panel +# noise, and this panel's nRef is 1000, so it correctly shrinks hard. That is +# the estimator working, not failing -- see the heritability vignette. + +usethis::use_data(ldEigenExample, overwrite = TRUE, compress = "xz") +usethis::use_data(ldScoreExample, overwrite = TRUE, compress = "xz") diff --git a/inst/scripts/build_sldsc_upstream_z.R b/inst/scripts/build_sldsc_upstream_z.R new file mode 100644 index 00000000..222b02e4 --- /dev/null +++ b/inst/scripts/build_sldsc_upstream_z.R @@ -0,0 +1,61 @@ +# ============================================================================= +# Rebuild tests/testthat/test_data/sldscUpstreamZ.rds -- the z-scores the +# upstream-parity tests in test_h2EstimationWrappers.R are compared against. +# ----------------------------------------------------------------------------- +# These are stored rather than re-simulated inside the test because the draw +# uses eigen(), and eigen() fixes eigenvectors only up to SIGN. The sign a +# given LAPACK build returns is arbitrary, so regenerating from a seed +# produced different data on linux-64 than on osx-arm64 / linux-aarch64 -- +# and the expected numbers came from running upstream (ldsc's +# ldscore.regressions.Hsq, HDL, LDER, gldsc) on one platform's realization. +# That made three of those tests fail on linux-64 only. +# +# Two things must move together, or the tests silently stop meaning anything: +# +# 1. Rerunning this script invalidates the expected values in +# test_h2EstimationWrappers.R. Re-derive them from upstream on the NEW +# vectors at the same time. +# 2. These vectors are drawn over ldScoreExample's LD blocks, so rebuilding +# that object (build_h2_examples.R) requires rebuilding these too. +# ============================================================================= + +suppressMessages(devtools::load_all(".", quiet = TRUE, export_all = FALSE)) +data(ldScoreExample) + +# EXACT copy of the in-test generator, so the captured z is the one the +# pinned upstream values were produced from. +simZ <- function(ref, h2, n, seed) { + M <- length(ref) + perSnpVar <- rep(h2 / M, M) + set.seed(seed) + z <- numeric(M) + for (b in pecotmr:::getLdMatrixList(ref)) { + idx <- b$snpIdx + p <- length(idx) + sigma <- n * (b$R %*% diag(perSnpVar[idx], p) %*% b$R) + b$R + e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) + z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) + } + z +} +# Every (h2, n, seed) the test file asks for. Keep in step with the call +# sites of .sldscUpstreamZ() in test_h2EstimationWrappers.R -- a missing +# entry is a hard error there, not a silent re-simulation. +cases <- c( + list( + c(0.4, 1e4, 42), c(0.15, 4e3, 7), c(0.6, 2.5e4, 99), + c(0.3, 1e4, 5), c(0.6, 5e4, 9), c(0.4, 5e4, 3) + ), + # the HDL recovery test sweeps seeds 1:5 at (h2 = 0.4, n = 1e5) + lapply(1:5, function(s) c(0.4, 1e5, s)) +) +out <- list() +for (cs in cases) { + key <- paste(cs[[1]], cs[[2]], cs[[3]], sep = "_") + out[[key]] <- simZ(ldScoreExample, cs[[1]], cs[[2]], cs[[3]]) +} +saveRDS(out, "tests/testthat/test_data/sldscUpstreamZ.rds", compress = "xz") +cat("keys:", paste(names(out), collapse = " | "), "\n") +cat("length each:", unique(lengths(out)), "\n") +cat("file size:", + file.size("tests/testthat/test_data/sldscUpstreamZ.rds"), "bytes\n") diff --git a/man/RangedTupleList-methods.Rd b/man/RangedTupleList-methods.Rd index b250d846..c20e7fda 100644 --- a/man/RangedTupleList-methods.Rd +++ b/man/RangedTupleList-methods.Rd @@ -55,6 +55,12 @@ \item{drop}{Passed through to the inherited method.} \item{FUN}{A function applied to each element, returning a \code{GRanges}.} + +\item{objects}{Further collections to append, as \code{c()} and +\code{append()} pass them.} + +\item{use.names, ignore.mcols, check}{Unused; present for generic +compatibility.} } \value{ \code{nrow()} and \code{ncol()} integers; \code{colnames()} a diff --git a/man/buildLdEigen.Rd b/man/buildLdEigen.Rd new file mode 100644 index 00000000..1311d6e1 --- /dev/null +++ b/man/buildLdEigen.Rd @@ -0,0 +1,68 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LdEigen.R +\name{buildLdEigen} +\alias{buildLdEigen} +\title{Build an LdEigen from loaded LD} +\usage{ +buildLdEigen( + ldBlockData, + nRef = NULL, + inSample = FALSE, + genome = NA_character_, + eigenvalueTruncation = 1 +) +} +\arguments{ +\item{ldBlockData}{An \code{\link{LdData}}, or a list of them, covering + the reference variants. An \code{LdData} whose correlation is a list of + per-block matrices contributes one LD block per matrix; one whose + correlation is a single matrix contributes one block. Blocks are kept in + the order given, and that order defines the variant order of the result. + + Block structure matters downstream: \code{\link{estimateH2}} takes its + standard error from a delete-one-block jackknife, so it requires at + least two blocks and wants many more. Loading a whole region as one + dense matrix yields a single block.} + +\item{nRef}{Integer, the LD reference panel sample size. Defaults to the +size recorded by the supplied \code{LdData}; required when they record +none, and an error when they disagree.} + +\item{inSample}{Logical, whether the reference is the GWAS cohort itself. +Selects LDER's weighting and HDL's finite-reference correction.} + +\item{genome}{Character, genome build. Defaults to the build recorded by +the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves +unset.} + +\item{eigenvalueTruncation}{Numeric in (0, 1]; the proportion of each +block's eigenvalue mass to retain. \code{1} (the default) keeps every +component; HDL conventionally uses \code{0.9}.} +} +\value{ +An \code{LdEigen} over every variant in \code{ldBlockData}. +} +\description{ +Eigendecompose already-loaded LD, block by block, into the + \code{LdEigen} that \code{\link{estimateH2}} consumes for + \code{method = "lder"} and \code{method = "hdl"}. This is the supported + route from an LD reference to an h2 input: \code{\link{LdEigen}} itself + is the low-level constructor and expects the decompositions to have been + computed already. + + No file I/O happens here. Read the LD first with + \code{\link{loadLdMatrix}} -- passing a vector of regions returns one + \code{LdData} per block -- then pass the result in. +} +\examples{ +meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", + package = "pecotmr") +ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") +ldEigen <- buildLdEigen(ld, genome = "hg38") +ldEigen +length(getEigenList(ldEigen)) +} +\seealso{ +\code{\link{buildLdScore}} for the g-LDSC input, + \code{\link{estimateH2}}, \code{\link{loadLdMatrix}} +} diff --git a/man/buildLdScore.Rd b/man/buildLdScore.Rd new file mode 100644 index 00000000..29d5f3f9 --- /dev/null +++ b/man/buildLdScore.Rd @@ -0,0 +1,75 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/LdScore.R +\name{buildLdScore} +\alias{buildLdScore} +\title{Build an LdScore from loaded LD} +\usage{ +buildLdScore( + ldBlockData, + nRef = NULL, + inSample = FALSE, + genome = NA_character_, + ldScoreWeights = NULL, + keepLdMatrices = TRUE +) +} +\arguments{ +\item{ldBlockData}{An \code{\link{LdData}}, or a list of them, covering + the reference variants. An \code{LdData} whose correlation is a list of + per-block matrices contributes one LD block per matrix; one whose + correlation is a single matrix contributes one block. Blocks are kept in + the order given, and that order defines the variant order of the result. + + Block structure matters downstream: \code{\link{estimateH2}} takes its + standard error from a delete-one-block jackknife, so it requires at + least two blocks and wants many more. Loading a whole region as one + dense matrix yields a single block.} + +\item{nRef}{Integer, the LD reference panel sample size. Defaults to the +size recorded by the supplied \code{LdData}; required when they record +none, and an error when they disagree.} + +\item{inSample}{Logical, whether the reference is the GWAS cohort itself.} + +\item{genome}{Character, genome build. Defaults to the build recorded by +the supplied \code{LdData}, which \code{\link{loadLdMatrix}} leaves +unset.} + +\item{ldScoreWeights}{Optional numeric regression weights, one per variant. +Defaults to the conventional \eqn{1/\max(\ell_j, 1)}.} + +\item{keepLdMatrices}{Logical. Keep each block's LD matrix on the result. +\code{TRUE} (the default) is required for \code{method = "gldsc"}, +which forms its FGLS residual covariance from them and errors without +them. \code{FALSE} drops them, leaving a scores-only object.} +} +\value{ +An \code{LdScore} over every variant in \code{ldBlockData}. +} +\description{ +Compute per-variant LD scores from already-loaded LD, block by + block, into the \code{LdScore} that \code{\link{estimateH2}} consumes + for \code{method = "gldsc"}. This is the supported route from an LD + reference to an h2 input: \code{\link{LdScore}} itself is the low-level + constructor and expects the scores to have been computed already. + + The score is \eqn{\ell_j = \sum_k r^2_{jk}} within each block, the same + quantity \code{\link{computeLdScores}} reconstructs from an + \code{\link{LdEigen}}, so the two agree on a shared reference. + + No file I/O happens here. Read the LD first with + \code{\link{loadLdMatrix}} -- passing a vector of regions returns one + \code{LdData} per block -- then pass the result in. +} +\examples{ +meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", + package = "pecotmr") +ld <- loadLdMatrix(meta, region = "chr22:10000000-19000000") +ldScore <- buildLdScore(ld, genome = "hg38") +ldScore +head(getLdScores(ldScore)) +} +\seealso{ +\code{\link{buildLdEigen}} for the LDER / HDL input, + \code{\link{estimateH2}}, \code{\link{computeLdScores}} +} diff --git a/man/checkGenomeBuild.Rd b/man/checkGenomeBuild.Rd index 039d5087..cf76db30 100644 --- a/man/checkGenomeBuild.Rd +++ b/man/checkGenomeBuild.Rd @@ -14,6 +14,10 @@ TRUE if all match, error otherwise. } \description{ Check that genome builds match between objects. Each object - contributes a single genome build (from its \code{genome} slot). + contributes a single genome build (from its \code{genome} slot). An + object that records no build is skipped rather than treated as a + mismatch: \code{loadLdMatrix()} leaves the build unset, so an LD + reference built from it names no build, and an unknown build cannot + contradict a known one. } \keyword{internal} diff --git a/man/dot-penalizedRssWeights.Rd b/man/dot-penalizedRssWeights.Rd index cbe9e538..a89ec099 100644 --- a/man/dot-penalizedRssWeights.Rd +++ b/man/dot-penalizedRssWeights.Rd @@ -13,7 +13,7 @@ alpha = 1, lambda0 = 0, lambda2 = 0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) } diff --git a/man/enforceDesignFullRank.Rd b/man/enforceDesignFullRank.Rd index a55b8560..2c6c739a 100644 --- a/man/enforceDesignFullRank.Rd +++ b/man/enforceDesignFullRank.Rd @@ -7,7 +7,7 @@ enforceDesignFullRank( X, C, - strategy = c("correlation", "variance", "response_correlation"), + strategy = c("correlation", "variance", "responseCorrelation"), response = NULL, maxIterations = 300L, corrThresholds = seq(0.75, 0.5, by = -0.05), @@ -25,7 +25,7 @@ Pass \code{NULL} or a zero-column matrix when there are no covariates.} \item{strategy}{Passed through to \code{dropCollinearColumns}.} \item{response}{Passed through to \code{dropCollinearColumns} when -\code{strategy = "response_correlation"}.} +\code{strategy = "responseCorrelation"}.} \item{maxIterations}{Integer. Hard cap on the iterative-prune loop. Default 300.} diff --git a/man/estimateH2.Rd b/man/estimateH2.Rd index 781b75ae..a75f6101 100644 --- a/man/estimateH2.Rd +++ b/man/estimateH2.Rd @@ -27,9 +27,27 @@ estimateH2( \arguments{ \item{sumstats}{A \code{GwasSumStats} object.} -\item{ldRef}{An \code{LdStatistic} object (method-appropriate subclass).} +\item{ldRef}{An \code{LdStatistic} object (method-appropriate subclass): +an \code{\link{LdScore}} for \code{"sldsc"} / \code{"gldsc"}, an +\code{\link{LdEigen}} for \code{"lder"} / \code{"hdl"}. Build either +from loaded LD with \code{\link{buildLdScore}} / +\code{\link{buildLdEigen}}.} -\item{method}{Character, one of "lder", "gldsc", "hdl".} +\item{method}{Character, one of \code{"lder"} (the default), +\code{"sldsc"}, \code{"gldsc"} or \code{"hdl"}: +\describe{ + \item{\code{"sldsc"}}{Stratified LD score regression (Finucane et al. + 2015): weighted least squares of \eqn{\chi^2} on LD scores. Needs + only per-variant scores when unstratified, so it is the cheapest of + the four and the only one that runs on a scores-only + \code{LdScore}.} + \item{\code{"gldsc"}}{Generalized LD score regression (Xiong et al. + 2024): GLS using the full per-block LD matrices.} + \item{\code{"lder"}}{LD eigenvalue regression (Song et al. 2022).} + \item{\code{"hdl"}}{High-definition likelihood (Ning et al. 2020), + stratified as sHDL. Models reference-panel noise explicitly, so it + shrinks hard when \code{nRef} is small.} +}} \item{annotations}{An \code{AnnotationMatrix} object, or NULL for unstratified estimation.} @@ -45,19 +63,26 @@ this study; \code{NULL} matches all studies.} An \code{H2Estimate} object. } \description{ -Estimate SNP heritability from GWAS summary statistics using one - of three methods: LDER, g-LDSC, or HDL/sHDL. +Estimate SNP heritability from GWAS summary statistics using + one of four methods: S-LDSC, g-LDSC, LDER, or HDL/sHDL. Supplying + \code{annotations} makes any of them stratified. } \examples{ -data(ldEigenExample) -gr <- GenomicRanges::GRanges("chr1", - IRanges::IRanges(seq(50, by = 100, length.out = 20), width = 1)) -S4Vectors::mcols(gr) <- S4Vectors::DataFrame(SNP = paste0("rs", 1:20), - A1 = "A", A2 = "G", Z = rnorm(20), N = 10000L) +data(ldScoreExample) +# The estimators index the z-scores by the reference's own variant order, +# so build the sumstats from the reference rather than alongside it. +gr <- as(ldScoreExample, "GRanges") +set.seed(1) +S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = names(ldScoreExample), + A1 = S4Vectors::mcols(ldScoreExample)$A1, + A2 = S4Vectors::mcols(ldScoreExample)$A2, + Z = rnorm(length(ldScoreExample)), + N = 100000L) panel <- readGenotypes( system.file("extdata", "toy_ref.bed", package = "pecotmr") ) ss <- GwasSumStats(study = "trait1", entry = list(gr), - genome = "hg19", ldSketch = panel) -estimateH2(ss, ldEigenExample, method = "lder") + genome = getGenome(ldScoreExample), ldSketch = panel) +estimateH2(ss, ldScoreExample, method = "sldsc") } diff --git a/man/filterRelatedness.Rd b/man/filterRelatedness.Rd index b824116a..0db8f7f4 100644 --- a/man/filterRelatedness.Rd +++ b/man/filterRelatedness.Rd @@ -7,7 +7,7 @@ filterRelatedness( relatedness, relatednessThreshold = 0.0625, - analysisType = c("maximize_unrelated", "maximize_cases"), + analysisType = c("maximizeUnrelated", "maximizeCases"), relatednessIid1 = "IID1", relatednessIid2 = "IID2", relatednessFid1 = NULL, @@ -33,8 +33,8 @@ filterRelatedness( \item{relatednessThreshold}{Kinship threshold above which individuals are considered related (default 0.0625, i.e. 2nd degree).} -\item{analysisType}{One of \code{"maximize_unrelated"} (default) or -\code{"maximize_cases"}. The latter preserves cases in case-control +\item{analysisType}{One of \code{"maximizeUnrelated"} (default) or +\code{"maximizeCases"}. The latter preserves cases in case-control studies.} \item{relatednessIid1}{Column name for first individual ID (default "IID1").} @@ -49,7 +49,7 @@ studies.} "PI_HAT").} \item{phenoData}{A data.frame with columns \code{IID} and the column named by -\code{phenoCol}. Required when \code{analysisType = "maximize_cases"}.} +\code{phenoCol}. Required when \code{analysisType = "maximizeCases"}.} \item{phenoCol}{Column name for the phenotype (default "pheno"). Expected to be binary (1 = case, 0 = control).} diff --git a/man/findOverlappingRegions.Rd b/man/findOverlappingRegions.Rd deleted file mode 100644 index 3f566609..00000000 --- a/man/findOverlappingRegions.Rd +++ /dev/null @@ -1,27 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{findOverlappingRegions} -\alias{findOverlappingRegions} -\title{Find which target regions overlap a query region} -\usage{ -findOverlappingRegions(query, targets) -} -\arguments{ -\item{query}{A single region string or single-row data.frame with -chrom/start/end columns.} - -\item{targets}{A character vector of region strings, or a multi-row -data.frame with chrom/start/end columns.} -} -\value{ -Integer vector of 1-based indices into \code{targets} that overlap - the query. Empty integer vector if no overlaps. -} -\description{ -Find which target regions overlap a query region -} -\examples{ -query <- "chr1:100-200" -targets <- c("chr1:150-250", "chr1:300-400") -findOverlappingRegions(query = query, targets = targets) -} diff --git a/man/getSumStats.Rd b/man/getSumStats.Rd index 80a0ff68..516cf2a8 100644 --- a/man/getSumStats.Rd +++ b/man/getSumStats.Rd @@ -42,8 +42,9 @@ this trait; \code{NULL} matches all traits.} enriched by \code{\link{qtlAssociationPostprocess}}, a logical \code{significant} mcol for that method is added to the returned entry (the significance is derived on the fly, not stored). Flat export flattens this -full entry GRanges (all mcols) directly; note \code{\link{getSumstatDf}} is -a fixed GWAS-schema view and does not carry the association columns.} +full entry GRanges (all mcols) directly; note +\code{\link{getSumStatsDf}} is a fixed GWAS-schema view and does not +carry the association columns.} \item{ranges}{A \code{GRanges} or \code{NULL} (default). A selected tuple can own several elements -- one per chromosome, since a multi-seqname entry is diff --git a/man/getSumstatDf.Rd b/man/getSumStatsDf.Rd similarity index 88% rename from man/getSumstatDf.Rd rename to man/getSumStatsDf.Rd index 5980cc38..762f7ceb 100644 --- a/man/getSumstatDf.Rd +++ b/man/getSumStatsDf.Rd @@ -1,15 +1,15 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, % R/gwasSumStats.R -\name{getSumstatDf} -\alias{getSumstatDf} -\alias{getSumstatDf,QtlSumStats-method} -\alias{getSumstatDf,GwasSumStats-method} +\name{getSumStatsDf} +\alias{getSumStatsDf} +\alias{getSumStatsDf,QtlSumStats-method} +\alias{getSumStatsDf,GwasSumStats-method} \title{Get Standardized Sumstat Data Frame for One Tuple} \usage{ -getSumstatDf(x, ...) +getSumStatsDf(x, ...) -\S4method{getSumstatDf}{QtlSumStats}( +\S4method{getSumStatsDf}{QtlSumStats}( x, study = NULL, context = NULL, @@ -19,7 +19,7 @@ getSumstatDf(x, ...) keepChrPrefix = TRUE ) -\S4method{getSumstatDf}{GwasSumStats}( +\S4method{getSumStatsDf}{GwasSumStats}( x, study = NULL, require = character(0), @@ -66,5 +66,5 @@ Return a per-tuple summary-statistics \code{data.frame} in the } \examples{ data(qtlSumStatsExample) -getSumstatDf(qtlSumStatsExample) +getSumStatsDf(qtlSumStatsExample) } diff --git a/man/getTraitNames.Rd b/man/getTraitNames.Rd deleted file mode 100644 index b0a811bc..00000000 --- a/man/getTraitNames.Rd +++ /dev/null @@ -1,46 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/SldscData.R -\name{getTraitNames} -\alias{getTraitNames} -\alias{getTraitNames,SldscData-method} -\title{Get the trait names from an SldscData} -\usage{ -getTraitNames(x) - -\S4method{getTraitNames}{SldscData}(x) -} -\arguments{ -\item{x}{An \code{\link{SldscData}} object.} -} -\value{ -A character vector of trait names. -} -\description{ -Get the trait names from an SldscData -} -\examples{ -mkRun <- function(cats) { - n <- length(cats) - list(categories = cats, tau = setNames(rep(1e-7, n), cats), - tauSe = setNames(rep(3e-8, n), cats), - enrichment = setNames(rep(2, n), cats), - enrichmentSe = setNames(rep(0.4, n), cats), - enrichmentP = setNames(rep(0.01, n), cats), - propH2 = setNames(rep(0.2, n), cats), - propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), - nBlocks = 10L) -} -annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), - annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) -frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), - MAF = rep(0.2, 6)) -mkTrait <- function() { - list(single = list(mkRun(c("annot_A_0", "baselineLD_0")), - mkRun(c("annot_B_0", "baselineLD_0"))), - joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) -} -traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -getTraitNames(sd) -} diff --git a/man/getTraits.Rd b/man/getTraits.Rd index 19adb2fb..5bf93a31 100644 --- a/man/getTraits.Rd +++ b/man/getTraits.Rd @@ -1,10 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/GwasFineMappingResult.R, -% R/QtlFineMappingResult.R, R/qtlSumStats.R, R/twasWeights.R +% R/QtlFineMappingResult.R, R/SldscData.R, R/qtlSumStats.R, R/twasWeights.R \name{getTraits} \alias{getTraits} \alias{getTraits,GwasFineMappingResult-method} \alias{getTraits,QtlFineMappingResult-method} +\alias{getTraits,SldscData-method} \alias{getTraits,QtlSumStats-method} \alias{getTraits,TwasWeights-method} \title{Get Unique Trait Names} @@ -15,6 +16,8 @@ getTraits(x) \S4method{getTraits}{QtlFineMappingResult}(x) +\S4method{getTraits}{SldscData}(x) + \S4method{getTraits}{QtlSumStats}(x) \S4method{getTraits}{TwasWeights}(x) @@ -27,7 +30,8 @@ Character vector of unique trait names. } \description{ Return the unique trait identifiers carried by a collection - class (e.g., \code{QtlSumStats}). + class (e.g., \code{QtlSumStats}), or the trait names of an + \code{\link{SldscData}}. } \examples{ data(qtlSumStatsExample) diff --git a/man/l0learnRssWeights.Rd b/man/l0learnRssWeights.Rd index fcc7d03b..95719d3d 100644 --- a/man/l0learnRssWeights.Rd +++ b/man/l0learnRssWeights.Rd @@ -12,7 +12,7 @@ l0learnRssWeights( lambda0 = exp(seq(log(0.001), log(1), length.out = 10)), lambda = NULL, lambda2 = 0, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), maxSwaps = 100, ... ) @@ -37,8 +37,8 @@ Default \code{"L0"}.} \item{lambda2}{L2 penalty weight (for L0L2). Default 0.} -\item{selection}{Selection strategy: \code{"ld_quadratic"} (default) or -\code{"min_fbeta"}.} +\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or +\code{"minFbeta"}.} \item{maxSwaps}{Maximum swap rounds per lambda. Default 100.} diff --git a/man/lassosumRssWeights.Rd b/man/lassosumRssWeights.Rd index fe0c7d53..d911d571 100644 --- a/man/lassosumRssWeights.Rd +++ b/man/lassosumRssWeights.Rd @@ -8,7 +8,7 @@ lassosumRssWeights( stat, LD, s = c(0.2, 0.5, 0.9, 1), - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) } @@ -21,9 +21,9 @@ sample sizes).} \item{s}{Numeric vector of shrinkage parameters to search over. Default: \code{c(0.2, 0.5, 0.9, 1.0)} following Mak et al (2017) and OTTERS.} -\item{selection}{Selection strategy. Default \code{"ld_quadratic"} uses +\item{selection}{Selection strategy. Default \code{"ldQuadratic"} uses \eqn{c^T \beta / \sqrt{\beta^T R \beta}} on the supplied LD matrix. -\code{"min_fbeta"} is retained as an explicit alternative for debugging.} +\code{"minFbeta"} is retained as an explicit alternative for debugging.} \item{...}{Additional arguments passed to \code{lassosumRss()}.} } diff --git a/man/ldEigenExample.Rd b/man/ldEigenExample.Rd index 8c70ddaa..3c673407 100644 --- a/man/ldEigenExample.Rd +++ b/man/ldEigenExample.Rd @@ -7,15 +7,22 @@ \format{ An \code{LdEigen} object (extends \code{LdStatistic}) with an \code{eigenList} of per-block \code{values} / \code{vectors} / - \code{snpIdx} - over 20 SNPs in 2 LD blocks. + \code{snpIdx} over 1300 variants in 14 LD blocks. } \description{ -A small synthetic \code{LdEigen} reference (per-block LD -eigen-decompositions over 20 SNPs in 2 blocks) for the heritability -estimators (\code{\link{estimateH2}} with \code{method = "lder"} or -\code{"hdl"}, and \code{\link{computeLdScores}}). All identifiers are -synthetic. +An \code{LdEigen} reference for the eigendecomposition-based +heritability estimators (\code{\link{estimateH2}} with +\code{method = "lder"} or \code{"hdl"}, and +\code{\link{computeLdScores}}). Built by \code{\link{buildLdEigen}} from +the first 14 chr22 LD blocks of the de-identified \code{protocol_example} +reference panel, so the LD is real rather than simulated. Describes the +same variants as \code{\link{ldScoreExample}}, so the four estimators can +be compared on one reference. + +The panel behind it has \code{nRef = 1000}. That is small enough that +\code{method = "hdl"}, which models reference-panel noise explicitly, +shrinks its estimate hard -- correct behaviour for a panel this size +rather than a fault. } \examples{ data(ldEigenExample) diff --git a/man/ldLoader.Rd b/man/ldLoader.Rd deleted file mode 100644 index 63217f6e..00000000 --- a/man/ldLoader.Rd +++ /dev/null @@ -1,84 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ld.R -\name{ldLoader} -\alias{ldLoader} -\title{Create an LD loader for on-demand block-wise LD retrieval} -\usage{ -ldLoader( - rList = NULL, - xList = NULL, - ldMetaPath = NULL, - regions = NULL, - ldInfo = NULL, - returnGenotype = FALSE, - maxVariants = NULL, - seed = NULL -) -} -\arguments{ -\item{rList}{List of G precomputed LD correlation matrices (p_g x p_g).} - -\item{xList}{List of G genotype matrices (n x p_g).} - -\item{ldMetaPath}{Path to a pecotmr LD metadata TSV file (as used by -\code{\link{loadLdMatrix}}).} - -\item{regions}{Character vector of G region strings (e.g., -\code{"chr22:17238266-19744294"}). Required when \code{ldMetaPath} is used.} - -\item{ldInfo}{A data.frame with column \code{LD_file} (paths to genotype -files or \code{.cor.xz} LD matrix files) and optionally \code{SNP_file} -(paths to companion \code{.bim} files for pre-computed blocks; defaults to -\code{paste0(LD_file, ".bim")} if absent). Genotype paths can be PLINK2 -prefixes, PLINK1 prefixes, VCF files, or GDS files. As returned by cTWAS -meta-data utilities.} - -\item{returnGenotype}{Logical. When using region mode, return the genotype -matrix X (\code{TRUE}) or LD correlation R (\code{FALSE}, default).} - -\item{maxVariants}{Integer or \code{NULL}. If set, randomly subsample blocks -larger than this to control memory usage.} - -\item{seed}{Integer or \code{NULL}. When \code{maxVariants} triggers -subsampling, seeds the draw (offset by the block index so each block is -independent yet reproducible) via a scoped \code{withr::local_seed}, so the -session RNG is left untouched. \code{NULL} (default) leaves the draw under -the session RNG, so an outer \code{set.seed()} still governs it.} -} -\value{ -An \code{ldLoaderSpec} object (an opaque list describing the source). - Pass it with a block index to \code{\link{loadLdBlock}} to load one block. -} -\description{ -Constructs a loader function that retrieves per-block LD matrices on demand. -This avoids loading all blocks into memory simultaneously, which is critical -for genome-wide analyses with hundreds of blocks. -} -\details{ -Four modes are supported: - -\describe{ - \item{list mode (R)}{Pre-loaded list of LD correlation matrices. - Simple but uses more memory. Set \code{R_list}.} - \item{list mode (X)}{Pre-loaded list of genotype matrices (n x p_g). - Set \code{X_list}.} - \item{region mode}{Loads LD from a pecotmr metadata TSV file on the fly - via \code{\link{loadLdMatrix}}. Memory-efficient for large datasets. - Set \code{ld_meta_path} and \code{regions}.} - \item{ldInfo mode}{Loads pre-computed LD blocks from \code{.cor.xz} - files listed in an \code{ldInfo} data.frame (as returned by - cTWAS meta-data utilities). Set \code{ldInfo}.} -} -} -\examples{ -# List mode with pre-computed LD -R1 <- diag(10) -R2 <- diag(15) -spec <- ldLoader(rList = list(R1, R2)) -loadLdBlock(spec, 1) # returns R1 -loadLdBlock(spec, 2) # returns R2 - -} -\seealso{ -\code{\link{loadLdBlock}} -} diff --git a/man/ldScoreExample.Rd b/man/ldScoreExample.Rd index ccc2cba1..73733f40 100644 --- a/man/ldScoreExample.Rd +++ b/man/ldScoreExample.Rd @@ -6,15 +6,21 @@ \title{Example LD-Score Reference} \format{ An \code{LdScore} object (extends \code{LdStatistic}) carrying - \code{ldScores}, \code{ldScoreWeights}, and \code{ldMatrixList} over 20 - SNPs - in 2 LD blocks. + \code{ldScores}, \code{ldScoreWeights}, and \code{ldMatrixList} over + 1300 variants in 14 LD blocks. } \description{ -A small synthetic \code{LdScore} reference (per-SNP LD scores, -weights, and per-block LD matrices over 20 SNPs in 2 blocks) for the -heritability estimators (\code{\link{estimateH2}} with -\code{method = "gldsc"}). All identifiers are synthetic. +An \code{LdScore} reference (per-variant LD scores, weights, +and per-block LD matrices) for the LD-score-based heritability estimators +(\code{\link{estimateH2}} with \code{method = "sldsc"} or +\code{"gldsc"}). Built by \code{\link{buildLdScore}} from the first 14 +chr22 LD blocks of the de-identified \code{protocol_example} reference +panel, so the LD is real rather than simulated. Describes the same variants +as \code{\link{ldEigenExample}}. + +The per-block LD matrices are retained because \code{"gldsc"} and +stratified \code{"sldsc"} both need them; unstratified \code{"sldsc"} +reads only the scores. } \examples{ data(ldScoreExample) diff --git a/man/loadLdBlock.Rd b/man/loadLdBlock.Rd deleted file mode 100644 index 1dbd5130..00000000 --- a/man/loadLdBlock.Rd +++ /dev/null @@ -1,28 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ld.R -\name{loadLdBlock} -\alias{loadLdBlock} -\title{Load one LD block from an ldLoader spec} -\usage{ -loadLdBlock(spec, g) -} -\arguments{ -\item{spec}{An \code{ldLoaderSpec} object returned by \code{\link{ldLoader}}.} - -\item{g}{Integer block index (1-based).} -} -\value{ -The LD correlation matrix or genotype matrix for block \code{g}. -} -\description{ -Given an \code{ldLoaderSpec} (from \code{\link{ldLoader}}) and a block index -\code{g}, load the corresponding LD correlation matrix (or the genotype -matrix, in region mode with \code{returnGenotype = TRUE}). -} -\examples{ -spec <- ldLoader(rList = list(diag(10), diag(15))) -loadLdBlock(spec, 1) -} -\seealso{ -\code{\link{ldLoader}} -} diff --git a/man/loadLdMatrix.Rd b/man/loadLdMatrix.Rd index fc17bdca..cd07214c 100644 --- a/man/loadLdMatrix.Rd +++ b/man/loadLdMatrix.Rd @@ -6,9 +6,14 @@ \usage{ loadLdMatrix( ldMetaFilePath, - region, + region = NULL, + block = NULL, extractCoordinates = NULL, returnGenotype = FALSE, + dropMonomorphic = FALSE, + materializeGenotypes = FALSE, + maxVariants = NULL, + seed = NULL, nSample = NULL ) } @@ -18,6 +23,12 @@ loadLdMatrix( \item{region}{Region of interest: "chr:start-end" string or data.frame with chrom/start/end.} +\item{block}{Integer block index (or vector of them), for sources that +carry no coordinates: an \code{ldInfo} table (the cTWAS \code{LD_map} +shape -- an \code{LD_file} column and optionally \code{SNP_file}), a +correlation or genotype matrix, or a list of either. Supply exactly one +of \code{region} and \code{block}.} + \item{extractCoordinates}{Optional data.frame with columns "chrom" and "pos" for specific coordinates extraction (only for pre-computed LD blocks).} @@ -26,6 +37,21 @@ FALSE (default): always return correlation matrix R. TRUE: return genotype matrix X (only valid for PLINK sources). "auto": return X for PLINK sources, R for pre-computed sources.} +\item{dropMonomorphic}{Logical. Drop variants with no variation, which +carry no LD and make a correlation undefined. Needs allele frequencies, +so it applies to genotype sources.} + +\item{materializeGenotypes}{Logical. Read the dosages once and keep them on +the returned object, so later access does no file I/O. Costs memory and +saves repeated reads.} + +\item{maxVariants}{Integer or \code{NULL}. Randomly thin any block larger +than this, to bound memory.} + +\item{seed}{Integer or \code{NULL}. Seeds the \code{maxVariants} draw, +offset by the block index so blocks are independent yet reproducible, via +a scoped \code{withr::local_seed} that leaves the session RNG alone.} + \item{nSample}{Optional sample size for computing variance (= 2*p*(1-p)*n/(n-1)). If NULL, ref_panel will not include variance or n_nomiss columns. Only used for PLINK genotype sources.} @@ -67,4 +93,6 @@ The metadata TSV must have columns: chrom, start, end, path. Two formats: meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", package = "pecotmr") loadLdMatrix(ldMetaFilePath = meta, region = "chr22:16000000-18000000") +# Several regions at once return one LdData per block. +length(loadLdMatrix(meta, region = rep("chr22:16000000-18000000", 2))) } diff --git a/man/loadLdSketch.Rd b/man/loadLdSketch.Rd deleted file mode 100644 index b06e7900..00000000 --- a/man/loadLdSketch.Rd +++ /dev/null @@ -1,35 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/ld.R -\name{loadLdSketch} -\alias{loadLdSketch} -\title{Load LD sketch genotypes for a region} -\usage{ -loadLdSketch(ldMetaFilePath, region, nSample = NULL) -} -\arguments{ -\item{ldMetaFilePath}{Path to the LD metadata TSV file.} - -\item{region}{Region of interest: "chr:start-end" string or data.frame with -chrom/start/end.} - -\item{nSample}{Optional original panel sample size for computing variance (= -2*p*(1-p)*n/(n-1)). Passed through to \code{loadLdMatrix()}.} -} -\value{ -An \code{LdData} S4 object with monomorphic variants removed. - Consumers should use S4 accessors: \code{getGenotypes()}, - \code{getRefPanel()}, \code{getVariantIds()}. The number of sketch samples - is \code{nrow(getGenotypes(result))}. -} -\description{ -Loads genotype data for a region via \code{loadLdMatrix(returnGenotype=TRUE)} -and removes monomorphic variants. Returns the raw genotype matrix and -metadata, which callers can use to derive either a correlation matrix R (for -summary-based weight training or fine-mapping) or an SVD (for TWAS z-score -computation). -} -\examples{ -meta <- system.file("extdata", "ld_reference", "ld_meta_file.tsv", - package = "pecotmr") -loadLdSketch(ldMetaFilePath = meta, region = "chr22:16000000-18000000") -} diff --git a/man/mashCovarianceComponents.Rd b/man/mashCovarianceComponents.Rd index a5131537..455e3095 100644 --- a/man/mashCovarianceComponents.Rd +++ b/man/mashCovarianceComponents.Rd @@ -8,7 +8,7 @@ mashCovarianceComponents( sumStatsList, alpha, vhat = NULL, - components = c("canonical", "pca", "flash", "flash_nonneg"), + components = c("canonical", "pca", "flash", "flashNonneg"), nPcs = NULL, inputScale = c("auto", "beta", "z"), setSeed = 999 @@ -23,7 +23,7 @@ least \code{"strong"} (the discovery set the covariances are learned on).} \item{vhat}{Residual correlation matrix (\code{V}); \code{NULL} -> identity.} \item{components}{Any of \code{"canonical"}, \code{"pca"}, \code{"flash"}, -\code{"flash_nonneg"}. Built in that fixed order.} +\code{"flashNonneg"}. Built in that fixed order.} \item{nPcs}{PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}.} diff --git a/man/mashModelFit.Rd b/man/mashModelFit.Rd index 966dfa7a..baad4d2e 100644 --- a/man/mashModelFit.Rd +++ b/man/mashModelFit.Rd @@ -22,8 +22,11 @@ mashModelFit( \item{alpha}{mash \code{alpha} (forwarded to \code{mashr::mash_set_data()}).} -\item{priorCovariances}{The prior covariance list (\code{U}) to fit with -- -e.g. the \code{$U} of a \code{\link{mashPriorCovariances}} result.} +\item{priorCovariances}{The prior covariance list (\code{U}) to fit with. +Either shape the producers return is accepted: a bare named list of +covariance matrices (\code{\link{mashCovarianceComponents}}) or the +\code{list(U, w, loglik)} a \code{\link{mashPriorCovariances}} result +carries, which is unwrapped to its \code{U}.} \item{vhat}{Residual correlation matrix (\code{V}); \code{NULL} -> identity.} @@ -63,7 +66,7 @@ vhat <- diag(length(conds)) dimnames(vhat) <- list(conds, conds) prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, components = "canonical") -model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, vhat = vhat) } \seealso{ diff --git a/man/mashPipeline.Rd b/man/mashPipeline.Rd index d18ff626..85da4a6f 100644 --- a/man/mashPipeline.Rd +++ b/man/mashPipeline.Rd @@ -8,6 +8,8 @@ mashPipeline( sumStatsList, alpha, residualCorrelation = NULL, + residualCorrelationMethod = c("identity", "simple", "simpleSpecific", "corshrink", + "mle"), priorCovariances = NULL, nPcs = NULL, inputScale = c("auto", "beta", "z"), @@ -18,22 +20,48 @@ mashPipeline( \item{sumStatsList}{Named list (or \code{SimpleList}) of \code{\link{QtlSumStats}} or \code{\link{GwasSumStats}} objects. Required names: \code{"strong"} (discovery variants), \code{"random"} (random -background). Optional: \code{"null"} (for residual correlation estimation).} +background, the partition the mixture weights are fit on). Optional: +\code{"null"} (null variants), needed only by the +\code{residualCorrelationMethod} values that estimate \eqn{\hat V} from +them.} \item{alpha}{Numeric (length 1). Variance-stabilising-transform exponent forwarded to \code{mashr::mash_set_data()}. Use \code{alpha = 0} on the BETA scale, \code{alpha = 1} on the Z scale.} \item{residualCorrelation}{Optional pre-computed residual correlation matrix -(\code{Vhat}). When supplied, replaces the inline -\code{mashr::estimate_null_correlation_simple()} call entirely and the -\code{"random"} slot of \code{sumStatsList} becomes optional (the function -does not need it for anything else). Useful when \code{Vhat} was estimated -previously on a larger reference and shipped as a static artefact (the -legacy MWE pattern).} +(\code{Vhat}). When supplied, it is used as-is: +\code{residualCorrelationMethod} is not consulted, and the +\code{"random"} slot of \code{sumStatsList} becomes optional (the +function does not need it for anything else). Useful when \code{Vhat} was +estimated previously on a larger reference and shipped as a static +artefact (the legacy MWE pattern).} + +\item{residualCorrelationMethod}{How to estimate \eqn{\hat V} when + \code{residualCorrelation} is not supplied; forwarded to + \code{\link{mashResidualCorrelation}}, which is where each estimator is + described. + + \code{"identity"} (the default) takes the residual correlation to be the + identity, needs no extra partition, and never depends on which partitions + were supplied. It is the safe default rather than the best one: it + assumes conditions share no residual correlation, which + overlapping-sample designs -- the usual multi-context QTL case, where the + same donors are measured in every context -- violate. Supplying a + \code{"null"} partition while leaving this at \code{"identity"} reports + that the partition is unused, since that combination is more often an + oversight than an intent. + + The estimators differ in what they require: \code{"simple"}, + \code{"simpleSpecific"} and \code{"corshrink"} need a \code{"null"} + entry; \code{"mle"} needs \code{"random"} plus a supplied + \code{priorCovariances} to refine against. A named method whose + requirement is unmet is a hard error, not a silent fallback.} \item{priorCovariances}{Optional named list of square covariance matrices -(the \code{Ulist} \code{mashr::mash()} consumes). When supplied, replaces +(the \code{Ulist} \code{mashr::mash()} consumes), or a +\code{\link{mashPriorCovariances}} result, which is unwrapped to its +\code{U}. When supplied, replaces the canonical + PCA + flash + ED chain (\code{cov_canonical} / \code{cov_pca} / \code{cov_flash} / \code{cov_ed}) entirely; mash sees only the supplied matrices. Every entry must be a \code{ncol(Bhat) x ncol(Bhat)} diff --git a/man/mashPosterior.Rd b/man/mashPosterior.Rd index 1ced89ae..15be4664 100644 --- a/man/mashPosterior.Rd +++ b/man/mashPosterior.Rd @@ -63,7 +63,7 @@ vhat <- diag(length(conds)) dimnames(vhat) <- list(conds, conds) prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, components = "canonical") -model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, vhat = vhat) mashPosterior(model, mk("strong.b", "strong.s"), alpha = 0, vhat = vhat) } diff --git a/man/mashPriorCovariances.Rd b/man/mashPriorCovariances.Rd index ecc5276a..6939227a 100644 --- a/man/mashPriorCovariances.Rd +++ b/man/mashPriorCovariances.Rd @@ -8,7 +8,7 @@ mashPriorCovariances( sumStatsList, alpha, vhat = NULL, - components = c("canonical", "pca", "flash", "flash_nonneg"), + components = c("canonical", "pca", "flash", "flashNonneg"), engine = c("cov_ed", "ud", "ud_ted"), nPcs = NULL, priorCovariances = NULL, @@ -29,7 +29,7 @@ least \code{"strong"} (the discovery set the covariances are learned on).} \item{components}{Data-driven covariance components, any of \code{"canonical"}, \code{"pca"}, \code{"flash"} (default -\code{cov_flash}), \code{"flash_nonneg"} (\code{cov_flash(factors = +\code{cov_flash}), \code{"flashNonneg"} (\code{cov_flash(factors = "nonneg")}). Built in that fixed order. Ignored by the \code{"ud"} / \code{"ud_ted"} engines.} @@ -43,12 +43,16 @@ not the default; \code{"ud_ted"} additionally needs i.i.d. (z-scale) data).} \item{nPcs}{PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}.} \item{priorCovariances}{Optional caller-supplied prior \code{U}: a non-empty -named list of \code{nCond x nCond} matrices. When supplied, the covariance -chain is bypassed and only the mixture-weight fit runs.} +named list of \code{nCond x nCond} matrices, or a +\code{\link{mashPriorCovariances}} result, which is unwrapped to its +\code{U}. When supplied, the covariance chain is bypassed and only the +mixture-weight fit runs.} \item{priorComponents}{Optional caller-supplied raw covariance components (a non-empty named list, e.g. the concatenated -\code{\link{mashCovarianceComponents}} outputs). When supplied, these are +\code{\link{mashCovarianceComponents}} outputs, or a +\code{\link{mashPriorCovariances}} result, which is unwrapped to its +\code{U}). When supplied, these are refined by \code{engine} instead of being rebuilt internally -- the mixture-prior pipeline where separate steps built the components. \code{components} / \code{nPcs} are then ignored. Distinct from @@ -76,7 +80,7 @@ Build the mash prior covariance list \code{U} and mixture collection. Split out of \code{\link{mashPipeline}} so the covariance-estimation chain lives in one place. The default builds every non-udr covariance component (\code{canonical + pca + flash + - flash_nonneg}) and refines them with mashr extreme deconvolution + flashNonneg}) and refines them with mashr extreme deconvolution (\code{cov_ed}). } \examples{ diff --git a/man/mashResidualCorrelation.Rd b/man/mashResidualCorrelation.Rd index 861c0537..adb6617a 100644 --- a/man/mashResidualCorrelation.Rd +++ b/man/mashResidualCorrelation.Rd @@ -7,7 +7,7 @@ mashResidualCorrelation( sumStatsList, alpha, - method = c("simple", "identity", "mle", "corshrink", "simple_specific"), + method = c("simple", "identity", "mle", "corshrink", "simpleSpecific"), priorCovariances = NULL, nSubset = 6000L, maxIter = 6L, @@ -27,14 +27,16 @@ off \code{"strong"}.} \item{method}{Estimator, all on the \code{"null"} partition unless noted. \code{"simple"} = mashr \code{estimate_null_correlation_simple()}; \code{"identity"} = \code{diag(nConditions)} (reads only \code{"strong"}); -\code{"simple_specific"} = \code{Matrix::nearPD(cov(nullZ), corr = TRUE)}; +\code{"simpleSpecific"} = \code{Matrix::nearPD(cov(nullZ), corr = TRUE)}; \code{"corshrink"} = \code{CorShrink::CorShrinkData()} adaptive-shrinkage correlation (needs the \pkg{CorShrink} package); \code{"mle"} = \code{mashr::mash_estimate_corr_em()} on a random subset (needs \code{"random"} + \code{priorCovariances}).} \item{priorCovariances}{Prior \code{U} list (required by \code{method = -"mle"}).} +"mle"}). Accepts a bare named list of covariance matrices or a +\code{\link{mashPriorCovariances}} result, which is unwrapped to its +\code{U}.} \item{nSubset, maxIter}{\code{method = "mle"} controls (random-subset size and EM iterations).} diff --git a/man/mcpRssWeights.Rd b/man/mcpRssWeights.Rd index 058c88bc..d1293bb5 100644 --- a/man/mcpRssWeights.Rd +++ b/man/mcpRssWeights.Rd @@ -10,7 +10,7 @@ mcpRssWeights( s = c(0.2, 0.5, 0.9, 1), gamma = 3, alpha = 1, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) } @@ -27,8 +27,8 @@ sample sizes).} \item{alpha}{Elastic-net mixing (1 = pure L1). Default 1.} -\item{selection}{Selection strategy: \code{"ld_quadratic"} (default) or -\code{"min_fbeta"}.} +\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or +\code{"minFbeta"}.} \item{...}{Additional arguments passed to \code{penalizedRss()}.} } diff --git a/man/mrAshRssWeights.Rd b/man/mrashRssWeights.Rd similarity index 88% rename from man/mrAshRssWeights.Rd rename to man/mrashRssWeights.Rd index b425c91f..d943a86b 100644 --- a/man/mrAshRssWeights.Rd +++ b/man/mrashRssWeights.Rd @@ -1,10 +1,10 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/regularizedRegressionWrappers.R -\name{mrAshRssWeights} -\alias{mrAshRssWeights} +\name{mrashRssWeights} +\alias{mrashRssWeights} \title{Extract weights from mr.ash.rss (susieR)} \usage{ -mrAshRssWeights(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ...) +mrashRssWeights(stat, LD, varY, sigma2E, s0, w0, z = numeric(0), ...) } \arguments{ \item{stat}{A list of summary statistics with elements \code{b} (effect @@ -43,6 +43,6 @@ ss <- lapply(seq_len(ncol(X)), function(j) { }) stat <- list(b = vapply(ss, `[`, numeric(1), 1L), seb = vapply(ss, `[`, numeric(1), 2L), n = rep(nrow(X), ncol(X))) -mrAshRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), +mrashRssWeights(stat, cor(X), varY = var(y), sigma2E = var(y), s0 = c(0, 0.1, 0.5), w0 = c(0.8, 0.1, 0.1)) } diff --git a/man/pecotmr-h2-sldsc.Rd b/man/pecotmr-h2-sldsc.Rd new file mode 100644 index 00000000..e21a2ea2 --- /dev/null +++ b/man/pecotmr-h2-sldsc.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/h2EstimationWrappers.R +\name{pecotmr-h2-sldsc} +\alias{pecotmr-h2-sldsc} +\title{S-LDSC: Stratified LD Score Regression} +\description{ +Estimate heritability and functional enrichment by weighted + least squares on LD scores (Finucane et al. 2015) -- the original method + the other three estimators descend from. Per-variant \eqn{\chi^2_j} is + regressed on annotation-stratified LD scores + \eqn{\ell_{jC} = \sum_{k \in C} r^2_{jk}} with a confounding + intercept, fitting + \eqn{E[\chi^2_j] = N \sum_C \tau_C \ell_{jC} + Na + 1}. + + Weights are LDSC's two multiplied factors, both floored at 1: the + heteroskedasticity term \eqn{1 / (2 E[\chi^2_j]^2)}, iterated on the + fitted values, and the overcounting term \eqn{1 / \ell_j} that stops + variants in strong LD from being counted many times. Standard errors come + from a delete-one-block jackknife over the LD blocks. + + Two routes are taken, matching \code{ldsc.py} -- the split is on + annotation count, not on preference: + \describe{ + \item{unstratified}{the two-step estimator: the intercept is fit on + the variants with \eqn{\chi^2 < 30}, then held fixed while the + slope is fit over all of them.} + \item{stratified}{no two-step -- upstream refuses one on a + partitioned design. Variants with \eqn{\chi^2 >} \code{max(0.001 + N, 80)} are dropped, the design is weighted once, and a single + weighted least-squares fit follows.} + } + + The intercept is reported as estimated and is not floored at 1: the + model implies at least 1, but a value below it is informative rather + than an error to clamp away, and clamping would move the heritability + too. + + Estimates agree with upstream \code{ldsc} to roughly 1e-6 relative; + the residual is a small ridge in the weighted solve, which upstream has + no equivalent of and which exists so an exactly singular design returns + a value rather than \code{NA}. + + Unlike \code{\link{pecotmr-h2-gldsc}} this needs only the per-variant + scores when unstratified, so it runs on a scores-only + \code{\link{LdScore}}; the stratified fit forms per-annotation scores + from the per-block LD matrices and therefore requires them. + + \strong{Scale.} LD score regression is a genome-scale method -- real + analyses regress over roughly a million variants. On a reference of a + few thousand the intercept is not identifiable (an unweighted OLS on + such data returns an intercept several times its true value), and the + heritability estimate is attenuated as a result. Treat small-reference + estimates as illustrative. \code{\link{pecotmr-h2-lder}} is much less + sensitive to reference size and is the better choice there. +} +\references{ +Finucane HK, Bulik-Sullivan B, Gusev A, et al. (2015). Partitioning + heritability by functional annotation using genome-wide association + summary statistics. Nature Genetics 47(11):1228-1235. +} +\keyword{internal} diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index 15e2ba43..ffac0d96 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -45,6 +45,9 @@ input used for credible-set purity and correlations.} \item{af}{Effect-allele frequencies (exported as the \code{af} column; never MAF). Default NULL.} +\item{n}{Optional per-variant sample size, exported as the \code{N} column. +Default NULL -> \code{N} falls back to the fit's own scalar sample size.} + \item{coverage}{Primary credible-set coverage.} \item{secondaryCoverage}{Additional credible-set coverages.} diff --git a/man/raiss.Rd b/man/raiss.Rd index bd7e590a..ee30378d 100644 --- a/man/raiss.Rd +++ b/man/raiss.Rd @@ -52,14 +52,17 @@ A list containing filtered and unfiltered results, and filtered LD matrix (ldMat is NULL when using genotypeMatrix path). } \description{ -This function is a part of the statistical library for SNP imputation from: -https://gitlab.pasteur.fr/statistical-genetics/raiss/-/blob/master/raiss/stat_models.py -It is R implementation of the imputation model described in the paper by -Bogdan Pasaniuc, Noah Zaitlen, et al., titled "Fast and accurate imputation -of summary statistics enhances evidence of functional enrichment", published -in Bioinformatics in 2014. +An R port of the RAISS summary-statistic imputation library, described in +Julienne H, Shi H, Pasaniuc B, Aschard H (2019), "RAISS: robust and accurate +imputation from summary statistics", Bioinformatics 35(22):4837-4839. +\doi{10.1093/bioinformatics/btz466} } \details{ +The imputation model it implements is the one introduced in Pasaniuc B, +Zaitlen N, et al. (2014), "Fast and accurate imputation of summary +statistics enhances evidence of functional enrichment", Bioinformatics +30(20):2906-2914. \doi{10.1093/bioinformatics/btu416} + This function can process either a single LD matrix or a list of LD matrices for different blocks. For a list of matrices, it processes each block separately and combines the results. Alternatively, it can accept a genotype diff --git a/man/readSldscFrq.Rd b/man/readSldscFrq.Rd index 27ed6315..b368a226 100644 --- a/man/readSldscFrq.Rd +++ b/man/readSldscFrq.Rd @@ -24,5 +24,5 @@ Reads the per-chromosome PLINK `.frq` files for the reference } \examples{ sldsc <- system.file("extdata", "sldsc", package = "pecotmr") -readSldscFrq(sldsc, plinkName = "reference.") +head(readSldscFrq(sldsc, plinkName = "reference.")) } diff --git a/man/regionsOverlap.Rd b/man/regionsOverlap.Rd deleted file mode 100644 index 9cb85ee7..00000000 --- a/man/regionsOverlap.Rd +++ /dev/null @@ -1,23 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{regionsOverlap} -\alias{regionsOverlap} -\title{Test whether two genomic regions overlap} -\usage{ -regionsOverlap(regionA, regionB) -} -\arguments{ -\item{regionA}{A region string ("chr1:100-200" or "1_100_200") or a -single-row data.frame with chrom/start/end columns.} - -\item{regionB}{A region string or single-row data.frame.} -} -\value{ -Logical scalar: TRUE if the regions share at least one base pair. -} -\description{ -Test whether two genomic regions overlap -} -\examples{ -regionsOverlap("chr1:100-200", "chr1:150-250") -} diff --git a/man/rescaleCovW0.Rd b/man/rescaleCovW0.Rd index 5eef95ae..1b98e9b3 100644 --- a/man/rescaleCovW0.Rd +++ b/man/rescaleCovW0.Rd @@ -17,3 +17,4 @@ A named numeric vector of prior-matrix weights with the \code{null} \description{ Re-normalize mrmash weight w0 to have total weight sum to 1 } +\keyword{internal} diff --git a/man/scadRssWeights.Rd b/man/scadRssWeights.Rd index a038709b..719963b9 100644 --- a/man/scadRssWeights.Rd +++ b/man/scadRssWeights.Rd @@ -10,7 +10,7 @@ scadRssWeights( s = c(0.2, 0.5, 0.9, 1), gamma = 3.7, alpha = 1, - selection = c("ld_quadratic", "min_fbeta"), + selection = c("ldQuadratic", "minFbeta"), ... ) } @@ -27,8 +27,8 @@ sample sizes).} \item{alpha}{Elastic-net mixing (1 = pure L1). Default 1.} -\item{selection}{Selection strategy: \code{"ld_quadratic"} (default) or -\code{"min_fbeta"}.} +\item{selection}{Selection strategy: \code{"ldQuadratic"} (default) or +\code{"minFbeta"}.} \item{...}{Additional arguments passed to \code{penalizedRss()}.} } diff --git a/man/sdpr.Rd b/man/sdpr.Rd index e962e70c..73958b21 100644 --- a/man/sdpr.Rd +++ b/man/sdpr.Rd @@ -69,8 +69,9 @@ arrays in a separate cohort). Default is 1.} \code{NULL} leaves the RNG state unchanged.} } \value{ -A list containing the estimated effect sizes (beta) and heritability - (h2). +A list with \code{betaEst} (the estimated effect sizes) and + \code{h2} (the estimated heritability). \code{sdprWeights()} returns + only \code{betaEst}; call this directly when you also want \code{h2}. } \description{ This function is a wrapper for the SDPR C++ implementation, which performs @@ -78,10 +79,11 @@ Markov Chain Monte Carlo (MCMC) for estimating effect sizes and heritability based on summary statistics and reference LD matrices. } \note{ -This function is a wrapper for the SDPR C++ implementation, which is a -rewritten and adopted version - of the SDPR package. The original SDPR documentation is available at - https://htmlpreview.github.io/?https://github.com/eldronzhou/SDPR/blob/main/doc/Manual.html +This function wraps a rewritten and adapted version of the SDPR C++ + implementation. SDPR is described in Zhou G, Zhao H (2021), "A fast and + robust Bayesian nonparametric method for prediction of complex traits + using summary statistics", PLoS Genetics 17(7): e1009697. + \doi{10.1371/journal.pgen.1009697} } \examples{ # Generate example data diff --git a/man/sldscPostprocessingPipeline.Rd b/man/sldscPostprocessingPipeline.Rd index f053dc15..3b2bfe32 100644 --- a/man/sldscPostprocessingPipeline.Rd +++ b/man/sldscPostprocessingPipeline.Rd @@ -52,8 +52,10 @@ mkRun <- function(cats) { enrichmentP = setNames(rep(0.01, n), cats), propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = 0.3, - tauBlocks = matrix(1e-7, 10, n, dimnames = list(NULL, cats)), + tauBlocks = matrix(1e-7 * seq(0.9, 1.1, length.out = 10), 10, n, + dimnames = list(NULL, cats)), nBlocks = 10L) +} annot <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), annot_A = c(1, 0, 1, 0, 1, 0), annot_B = c(2.1, 1.8, 2.5, 1.9, 2.3, 2)) frq <- data.frame(CHR = c(1, 1, 1, 2, 2, 2), SNP = paste0("rs", 1:6), @@ -64,9 +66,8 @@ mkTrait <- function() { joint = mkRun(c("annot_A_0", "annot_B_0", "baselineLD_0"))) } traits <- setNames(list(mkTrait(), mkTrait()), c("traitX", "traitY")) -sd <- SldscData(annot = annot, frq = frq, traits = traits) -sldscPostprocessingPipeline(sldscData = sd) -} +sldscData <- SldscData(annot = annot, frq = frq, traits = traits) +sldscPostprocessingPipeline(sldscData = sldscData) } \seealso{ \code{\link{SldscData}}, \code{\link{readSldscAnnot}}, diff --git a/man/twasWeightsPipeline.Rd b/man/twasWeightsPipeline.Rd index 57dffdf0..2624d587 100644 --- a/man/twasWeightsPipeline.Rd +++ b/man/twasWeightsPipeline.Rd @@ -105,7 +105,7 @@ embedded \code{QtlSumStats}, then rbinds the results.} \item{...}{Reserved for method-specific arguments.} \item{methods}{A character vector of short method names, a preset string -(\code{"default"} or \code{"fast_default"}), or a named list of +(\code{"default"} or \code{"fastDefault"}), or a named list of \code{_weights = args} entries. For QtlSumStats / GwasSumStats inputs the default switches to the RSS preset (\code{c("susieRss", "susieInfRss", "lassosumRss", "prsCs", "sdpr")}).} diff --git a/man/updateMashModelCov.Rd b/man/updateMashModelCov.Rd index 3f434a32..45dfe2fa 100644 --- a/man/updateMashModelCov.Rd +++ b/man/updateMashModelCov.Rd @@ -37,7 +37,7 @@ vhat <- diag(length(conds)) dimnames(vhat) <- list(conds, conds) prior <- mashPriorCovariances(ssl, alpha = 0, vhat = vhat, components = "canonical") -model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior$U, +model <- mashModelFit(ssl, alpha = 0, priorCovariances = prior, vhat = vhat) updateMashModelCov(model, allSamples = conds, samples = conds[1:3]) } diff --git a/man/variantIdToDf.Rd b/man/variantIdToDf.Rd deleted file mode 100644 index d32be8eb..00000000 --- a/man/variantIdToDf.Rd +++ /dev/null @@ -1,26 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/variantId.R -\name{variantIdToDf} -\alias{variantIdToDf} -\title{Parse variant IDs into a data frame} -\usage{ -variantIdToDf(variantId) -} -\arguments{ -\item{variantId}{A character vector of variant IDs.} -} -\value{ -A data.frame with columns \code{chrom}, \code{pos}, \code{A2}, - \code{A1}. -} -\description{ -Convenience wrapper around \code{\link{parseVariantId}} returning the parsed -\code{chrom}/\code{pos}/\code{A2}/\code{A1} data frame for a vector of -variant IDs. -} -\examples{ -variantIdToDf("chr1:100:A:G") -} -\seealso{ -\code{\link{parseVariantId}} -} diff --git a/man/writeSumstatsVcf.Rd b/man/writeSumStatsVcf.Rd similarity index 76% rename from man/writeSumstatsVcf.Rd rename to man/writeSumStatsVcf.Rd index b8410377..b03b988c 100644 --- a/man/writeSumstatsVcf.Rd +++ b/man/writeSumStatsVcf.Rd @@ -1,16 +1,16 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/AllGenerics.R, R/vcfWriter.R -\name{writeSumstatsVcf} -\alias{writeSumstatsVcf} -\alias{writeSumstatsVcf,GwasSumStats-method} -\alias{writeSumstatsVcf,FineMappingResultBase-method} +\name{writeSumStatsVcf} +\alias{writeSumStatsVcf} +\alias{writeSumStatsVcf,GwasSumStats-method} +\alias{writeSumStatsVcf,FineMappingResultBase-method} \title{Write summary statistics or fine-mapping results to VCF/BCF} \usage{ -writeSumstatsVcf(x, outputPath, sampleName = NULL, ...) +writeSumStatsVcf(x, outputPath, sampleName = NULL, ...) -\S4method{writeSumstatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, study = NULL, ...) +\S4method{writeSumStatsVcf}{GwasSumStats}(x, outputPath, sampleName = NULL, study = NULL, ...) -\S4method{writeSumstatsVcf}{FineMappingResultBase}( +\S4method{writeSumStatsVcf}{FineMappingResultBase}( x, outputPath, sampleName = NULL, @@ -60,11 +60,13 @@ Invisible path to the written file. } \description{ Creates a VCF object from GWAS summary statistics or fine-mapping results and -writes it to disk. Supports bgzipped VCF (.vcf.gz/.vcf.bgz) and BCF (.bcf) -output formats via VariantAnnotation and Rsamtools. +writes it to disk via VariantAnnotation and Rsamtools. Supports bgzipped +VCF (.vcf.gz/.vcf.bgz); BCF (.bcf) additionally needs a working +\code{Rsamtools::asBcf()}, which recent Rsamtools releases disable, so +prefer .vcf.bgz. } \examples{ data(gwasSumStatsS4Example) -writeSumstatsVcf( +writeSumStatsVcf( gwasSumStatsS4Example, outputPath = tempfile(fileext = ".vcf")) } diff --git a/tests/testthat/helper-colocboost.R b/tests/testthat/helper-colocboost.R new file mode 100644 index 00000000..9ea02a99 --- /dev/null +++ b/tests/testthat/helper-colocboost.R @@ -0,0 +1,73 @@ +# Raw colocboost run objects and the outcome-info lookup that +# ColocBoostResult and .cbToResultObject are assembled from. +# +# Shared because the class file and the pipeline file both need one: the +# class tests exercise the row expansion, the pipeline tests exercise how +# .cbToResultObject keys runs by analysis and gwasStudy. + +# A minimal stand-in for a colocboost object, shaped like the real one: +# cos_details keyed by cos_id, purity as a SQUARE matrix over sets, and +# top variables as a data frame with set ids for rownames. +.cbr_fake <- function( + ids = "cos1:y1_y2", + outcomes = list(c("t1", "t2")), + members = list(2L), + variants = list("chr1:200:C:T"), + npc = 0.9, + nRegion = 4L, + focal = FALSE +) { + regionIds <- str_c("chr1:", seq_len(nRegion) * 100L, ":C:T") + vcp <- set_names(seq_len(nRegion) / (nRegion * 2), regionIds) + purity <- matrix( + 1, + nrow = length(ids), + ncol = length(ids), + dimnames = list(ids, ids) + ) + structure( + list( + cos_summary = tibble( + cos_id = ids, + focal_outcome = focal, + top_variable = map_chr(variants, 1L), + top_variable_vcp = rep(0.8, length(ids)) + ), + vcp = vcp, + cos_details = list( + cos = list( + cos_index = set_names(members, ids), + cos_variables = set_names(variants, ids) + ), + cos_outcomes = list( + outcome_name = set_names(outcomes, ids) + ), + cos_vcp = set_names( + rep(list(as.numeric(vcp)), length(ids)), + ids + ), + cos_npc = set_names(rep(npc, length(ids)), ids), + cos_min_npc_outcome = set_names(rep(npc, length(ids)), ids), + cos_purity = list(min_abs_cor = purity), + cos_top_variables = data.frame( + top_index = unlist(members), + top_variables = unlist(variants), + row.names = ids, + stringsAsFactors = FALSE + ) + ) + ), + class = "colocboost" + ) +} + +.cbr_info <- function(names = c("t1", "t2")) { + data.frame( + name = names, + context = str_c("ctx", seq_along(names)), + trait = "GENE1", + study = "study1", + dataForm = "individual", + stringsAsFactors = FALSE + ) +} diff --git a/tests/testthat/helper-h2Classes.R b/tests/testthat/helper-h2Classes.R index 9d3418ac..fd67925b 100644 --- a/tests/testthat/helper-h2Classes.R +++ b/tests/testthat/helper-h2Classes.R @@ -175,3 +175,83 @@ makeGwasBlock <- function( ) obj } + + +# ============================================================================= +# LdData fixtures for buildLdEigen() / buildLdScore() +# ============================================================================= + +# The mcols a loadLdMatrix() LdData carries: variant_id rather than SNP, and +# allele_freq rather than MAF. The builders have to cope with that shape. +.testLdVariants <- function(n, chrom, startBp) { + bp <- seq(startBp, by = 100L, length.out = n) + gr <- GenomicRanges::GRanges( + seqnames = chrom, + ranges = IRanges::IRanges(start = as.integer(bp), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + variant_id = paste0(chrom, ":", bp, ":C:T"), + A1 = rep("T", n), + A2 = rep("C", n), + allele_freq = seq(0.2, 0.8, length.out = n) + ) + gr +} + +.testArBlock <- function(n, rho) { + rho^abs(outer(seq_len(n), seq_len(n), "-")) +} + +.testBlockMetadata <- function(sizes, chrom, gr) { + ends <- cumsum(sizes) + starts <- ends - sizes + 1L + tibble::tibble( + blockId = seq_along(sizes), + chrom = sub("^chr", "", chrom), + blockStart = as.integer(GenomicRanges::start(gr)[starts]), + blockEnd = as.integer(GenomicRanges::start(gr)[ends]), + size = as.integer(sizes), + startIdx = as.integer(starts), + endIdx = as.integer(ends) + ) +} + +# One block: correlation is a single matrix. +makeTestLdData <- function( + n = 6L, + chrom = "chr1", + startBp = 1000L, + rho = 0.5, + nRef = 500L +) { + gr <- .testLdVariants(n, chrom, startBp) + R <- .testArBlock(n, rho) + dimnames(R) <- list( + S4Vectors::mcols(gr)$variant_id, + S4Vectors::mcols(gr)$variant_id + ) + LdData( + correlation = R, + variants = gr, + blockMetadata = .testBlockMetadata(n, chrom, gr), + nRef = nRef + ) +} + +# Several blocks in one LdData: correlation is a list of per-block matrices +# and blockMetadata carries the startIdx/endIdx mapping into the variants. +makeTestLdDataMultiBlock <- function( + sizes = c(4L, 3L), + chrom = "chr1", + startBp = 1000L, + rho = 0.5, + nRef = 500L +) { + gr <- .testLdVariants(sum(sizes), chrom, startBp) + LdData( + correlation = lapply(sizes, .testArBlock, rho = rho), + variants = gr, + blockMetadata = .testBlockMetadata(sizes, chrom, gr), + nRef = nRef + ) +} diff --git a/tests/testthat/helper-sldsc.R b/tests/testthat/helper-sldsc.R index 7a4130d7..4d343307 100644 --- a/tests/testthat/helper-sldsc.R +++ b/tests/testthat/helper-sldsc.R @@ -243,8 +243,11 @@ propH2 = setNames(rep(0.2, n), cats), propSnps = setNames(rep(0.1, n), cats), h2g = h2g, + # Per-block tau has to vary: a constant matrix gives a jackknife + # tauStarSe of exactly 0, which drops every trait from the + # DerSimonian-Laird meta (nTraits == 0 and all-NA meta rows). tauBlocks = matrix( - rep(tau, nBlocks * n), + rep(tau * seq(0.9, 1.1, length.out = nBlocks), n), nBlocks, n, dimnames = list(NULL, cats) diff --git a/tests/testthat/test_AllClasses.R b/tests/testthat/test_AllClasses.R index 2bfb1493..c36e0f03 100644 --- a/tests/testthat/test_AllClasses.R +++ b/tests/testthat/test_AllClasses.R @@ -399,7 +399,7 @@ test_that("getVariantIds renders ids the same way the row classes do", { data(qtlSumStatsExample, envir = environment()) expect_equal( getVariantIds(qtlSumStatsExample), - getSumstatDf(qtlSumStatsExample, require = "Z")$variant_id + getSumStatsDf(qtlSumStatsExample, require = "Z")$variant_id ) expect_match(getVariantIds(qtlSumStatsExample)[[1L]], "^chr[^:]+:\\d+:") }) @@ -473,3 +473,83 @@ test_that("adjustPips drops non-overlapping entries and says so", { expect_equal(nrow(out), 1L) expect_equal(as.character(mcols(out)$study), "s1") }) + + +# =========================================================================== +# .ssStitchElements()'s `ranges` filter +# +# getSumStats(x, ranges = ) is a documented argument that nothing exercised: +# every call left it NULL and returned through the early exit, so the +# chromosome test and the overlap intersection were both cold. +# =========================================================================== + +test_that("getSumStats(ranges=) narrows the variants to the window", { + data(gwasSumStatsS4Example) + full <- getSumStats(gwasSumStatsS4Example) + span <- range(GenomicRanges::start(full)) + win <- GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(full))[[1L]], + IRanges::IRanges( + span[[1L]], + span[[1L]] + (span[[2L]] - span[[1L]]) %/% 4L + ) + ) + sub <- getSumStats(gwasSumStatsS4Example, ranges = win) + expect_s4_class(sub, "GRanges") + expect_lt(length(sub), length(full)) + expect_gt(length(sub), 0L) + expect_true(all(IRanges::overlapsAny(sub, win))) +}) + +test_that("getSumStats(ranges=) on another chromosome returns nothing", { + # The chromosome test short-circuits before overlapsAny(), which would + # otherwise warn about disjoint seqlevels. + data(gwasSumStatsS4Example) + off <- GenomicRanges::GRanges("chrZZ", IRanges::IRanges(1L, 100L)) + sub <- suppressWarnings(getSumStats(gwasSumStatsS4Example, ranges = off)) + expect_s4_class(sub, "GRanges") + expect_equal(length(sub), 0L) +}) + + +test_that("the genome check names a missing build and a mixed one", { + f <- pecotmr:::.sumStatsCheckGenome + gr <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(100L, 200L), width = 1L) + ) + # No build recorded anywhere. + expect_match(f(gr), "no genome build in seqinfo") + # Two different builds across seqlevels. + GenomeInfoDb::genome(gr) <- c("hg19", "hg38") + expect_match(f(gr), "names more than one genome build") + # A single build is accepted. + GenomeInfoDb::genome(gr) <- "hg38" + expect_null(f(gr)) +}) + + +test_that("an empty collection has no variants", { + setClass( + "RcEmptyKid", + contains = "RangedTupleList", + representation(genome = "character", ldSketch = "ANY", qcInfo = "list") + ) + empty <- new( + "RcEmptyKid", + GenomicRanges::GRangesList(), + genome = "hg38", + ldSketch = NULL, + qcInfo = list() + ) + expect_equal(nrow(empty), 0L) + expect_equal(pecotmr:::.rcAllVariants(empty), character(0)) +}) + +test_that("retained mass is NULL for a fit that never went through reconciliation", { + # NULL rather than a vector of 1s: nothing was dropped, so there is no + # mass to report. + expect_null(pecotmr:::.rcFitRetainedMass(NULL)) + expect_null(pecotmr:::.rcFitRetainedMass("not a fit")) + expect_equal(pecotmr:::.rcFitRetainedMass(list(retained_mass = 0.8)), 0.8) +}) diff --git a/tests/testthat/test_ColocBoostResult.R b/tests/testthat/test_ColocBoostResult.R index 8aa18856..3967cb9b 100644 --- a/tests/testthat/test_ColocBoostResult.R +++ b/tests/testthat/test_ColocBoostResult.R @@ -5,72 +5,6 @@ # pair, and it computes no PP.H0-PP.H4 decomposition at all. Several tests # below guard exactly that boundary. -# A minimal stand-in for a colocboost object, shaped like the real one: -# cos_details keyed by cos_id, purity as a SQUARE matrix over sets, and -# top variables as a data frame with set ids for rownames. -.cbr_fake <- function( - ids = "cos1:y1_y2", - outcomes = list(c("t1", "t2")), - members = list(2L), - variants = list("chr1:200:C:T"), - npc = 0.9, - nRegion = 4L, - focal = FALSE -) { - regionIds <- str_c("chr1:", seq_len(nRegion) * 100L, ":C:T") - vcp <- set_names(seq_len(nRegion) / (nRegion * 2), regionIds) - purity <- matrix( - 1, - nrow = length(ids), - ncol = length(ids), - dimnames = list(ids, ids) - ) - structure( - list( - cos_summary = tibble( - cos_id = ids, - focal_outcome = focal, - top_variable = map_chr(variants, 1L), - top_variable_vcp = rep(0.8, length(ids)) - ), - vcp = vcp, - cos_details = list( - cos = list( - cos_index = set_names(members, ids), - cos_variables = set_names(variants, ids) - ), - cos_outcomes = list( - outcome_name = set_names(outcomes, ids) - ), - cos_vcp = set_names( - rep(list(as.numeric(vcp)), length(ids)), - ids - ), - cos_npc = set_names(rep(npc, length(ids)), ids), - cos_min_npc_outcome = set_names(rep(npc, length(ids)), ids), - cos_purity = list(min_abs_cor = purity), - cos_top_variables = data.frame( - top_index = unlist(members), - top_variables = unlist(variants), - row.names = ids, - stringsAsFactors = FALSE - ) - ) - ), - class = "colocboost" - ) -} - -.cbr_info <- function(names = c("t1", "t2")) { - data.frame( - name = names, - context = str_c("ctx", seq_along(names)), - trait = "GENE1", - study = "study1", - dataForm = "individual", - stringsAsFactors = FALSE - ) -} test_that("ColocBoostResult: one element per confidence set", { x <- ColocBoostResult( @@ -442,3 +376,79 @@ test_that("validity names missing identity and outcomeInfo columns", { mcols(bad)$analysis <- NULL expect_error(methods::validObject(bad), "missing columns: analysis") }) + + +# =========================================================================== +# Empty-input paths +# +# The views and row builders were only ever driven by populated results, so +# their empty answers were never produced. +# =========================================================================== + +test_that("uncolocalized rows are empty when there is nothing to report", { + # Two separate exits: no ucos_details at all, and details carrying an + # empty index. + expect_equal(.cbrUncolocalizedRows(list(), "xqtl", NA_character_), list()) + expect_equal( + .cbrUncolocalizedRows( + list(ucos_details = list(ucos = list(ucos_index = list()))), + "xqtl", + NA_character_ + ), + list() + ) +}) + +test_that("a summary lookup that matches no set yields an NA row", { + # NA rather than zero rows: the set exists, its summary just is not there. + out <- .cbrSummaryFor( + list(cos_summary = data.frame(cos_id = "other")), + "missing_id" + ) + expect_equal(nrow(out), 1L) + expect_true(is.na(out$top_variable)) + expect_true(is.na(out$top_variable_vcp)) +}) + +test_that("the views answer an empty collection with empty tables", { + data(colocboostResultExample) + empty <- colocboostResultExample[0] + expect_equal(length(empty), 0L) + expect_equal(nrow(.cbrLongVariants(empty)), 0L) + expect_equal(nrow(getColocBoostOutcomes(empty)), 0L) +}) + +test_that("outcome info defaults to the empty frame and is not joined", { + # With no outcomeInfo the constructor substitutes the empty frame, and the + # outcomes view returns before attempting a join against it. + cb <- ColocBoostResult(list(.cbr_fake()), analysis = "xqtl") + expect_equal(nrow(cb@outcomeInfo), 0L) + out <- getColocBoostOutcomes(cb) + expect_gt(nrow(out), 0L) + expect_false(is_in("outcomeTrait", colnames(out))) +}) + + +test_that("validity names the outcomeInfo columns that are missing", { + cb <- ColocBoostResult(list(.cbr_fake()), analysis = "xqtl") + cb@outcomeInfo <- data.frame(name = "t1") + expect_match( + .cbrCheckOutcomeInfo(cb), + "outcomeInfo is missing columns: study, context, trait, dataForm" + ) +}) + +test_that("the region vcp skips runs that cannot supply one", { + # Two ways a run is unusable: no vcp at all, and a vcp whose names are + # missing so the variants cannot be placed. + unnamed <- c(0.5, 0.5) + expect_null(.cbrRegionVcp(list(list(vcp = unnamed)))) + expect_null(.cbrRegionVcp(list(list(vcp = NULL)))) + # ...and a later run that does carry one is still found. + gr <- .cbrRegionVcp(list( + list(vcp = NULL), + list(vcp = set_names(0.7, "chr1:100:C:T")) + )) + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 1L) +}) diff --git a/tests/testthat/test_ColocResult.R b/tests/testthat/test_ColocResult.R index 6c1127f9..2bf1ddae 100644 --- a/tests/testthat/test_ColocResult.R +++ b/tests/testthat/test_ColocResult.R @@ -322,6 +322,22 @@ test_that("purity is NA for every set when there is no LD reference", { expect_equal(.crPuritiesFor(out, NULL), c(NA_real_, NA_real_)) }) +test_that("purity is computed per set when an LD reference is supplied", { + # The counterpart of the NULL case above: with a panel in hand each set + # is mapped through .crPurityOne rather than short-circuiting to NA. + ids <- .cr_panelIds(3L) + out <- tibble(csVariants = list(ids, ids[[1L]])) + pur <- .crPuritiesFor(out, .cr_panel()) + expect_length(pur, 2L) + expect_false(anyNA(pur)) + expect_equal(pur[[2L]], 1) # singleton is pure by definition + expect_equal( + pur[[1L]], + .crPurityOne(ids, .cr_panel()), + tolerance = 1e-8 + ) +}) + # =========================================================================== # Validity # =========================================================================== @@ -351,3 +367,44 @@ test_that("validity names elements whose variants lack SNP.PP.H4", { "have no SNP.PP.H4 column in their variant metadata" ) }) + + +# =========================================================================== +# Empty-input paths +# +# Every view above was built from a populated result, so the early returns +# that answer an empty collection were never taken. +# =========================================================================== + +test_that("the views answer an empty collection with empty tables", { + empty <- ColocResult(.cr_pairs(), .cr_variants())[0] + expect_equal(length(empty), 0L) + expect_equal(nrow(.crLongVariants(empty)), 0L) + expect_equal(.crPairFilter(empty, 0, FALSE), integer(0)) + expect_equal(nrow(getColocGenes(empty)), 0L) +}) + +test_that("pivoting a per-row column that is absent yields the empty frame", { + # coloc only emits SNP.PP.H4.rowK for the rows it actually fitted. + expect_equal(nrow(.crPivotOne(9L, data.frame(a = 1))), 0L) +}) + +test_that("a NULL purity cutoff leaves the credible sets untouched", { + # NULL means "do not filter", which is different from filtering at 0. + out <- tibble(a = 1, purity = NA_real_) + expect_identical(.crApplyPurityFilter(out, NULL), out) +}) + +test_that("a pair with no variants contributes no credible set", { + # A fitted pair can still carry zero variants; it drops out of the credible + # set view rather than producing an empty row. + noVariants <- data.frame( + variant_id = character(0), + SNP.PP.H4 = numeric(0) + ) + cr <- ColocResult(.cr_pairs(), list(noVariants)) + expect_equal(length(cr[[1L]]), 0L) + expect_null(.crCsForPair(1L, cr, coverage = 0.95)) + # ...and the accessor over that result is an empty table, not an error. + expect_equal(nrow(getColocCredibleSets(cr)), 0L) +}) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index d2b41448..ece4412a 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -217,3 +217,12 @@ test_that("a joint column must be character", { "'jointStudies' column must be character \\(got integer\\)" ) }) + + +test_that("an empty ranged payload flattens to NULL", { + expect_null(pecotmr:::.ctwasPayloadAsDf(GenomicRanges::GRanges())) + expect_null(pecotmr:::.ctwasPayloadAsDf(NULL)) + # A non-GRanges payload is passed straight through. + df <- data.frame(a = 1) + expect_equal(pecotmr:::.ctwasPayloadAsDf(df), df) +}) diff --git a/tests/testthat/test_LdEigen.R b/tests/testthat/test_LdEigen.R index 929b9a86..a64d7247 100644 --- a/tests/testthat/test_LdEigen.R +++ b/tests/testthat/test_LdEigen.R @@ -108,3 +108,88 @@ test_that("subsetting an LdEigen is refused, not silently allowed", { expect_error(obj[1:5], "cannot be subset") expect_error(obj[1], "Recompute over the subset") }) + + +# ============================================================================= +# buildLdEigen +# ============================================================================= + +test_that("buildLdEigen decomposes a single-block LdData", { + ld <- makeTestLdData(n = 6L) + ref <- buildLdEigen(ld) + + expect_s4_class(ref, "LdEigen") + expect_equal(length(ref), 6L) + expect_equal(length(getEigenList(ref)), 1L) + expect_equal(length(getLdBlocks(ref)), 1L) + expect_equal(getNRef(ref), 500L) + expect_false(getInSample(ref)) + expect_equal(getEigenList(ref)[[1]]$snpIdx, 1:6) +}) + +test_that("buildLdEigen gives one block per matrix of a multi-block LdData", { + ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) + + expect_equal(length(ref), 7L) + blocks <- getEigenList(ref) + expect_equal(length(blocks), 2L) + # snpIdx must index the concatenated variant order, not each block's own. + expect_equal(blocks[[1]]$snpIdx, 1:4) + expect_equal(blocks[[2]]$snpIdx, 5:7) + expect_equal(length(getLdBlocks(ref)), 2L) +}) + +test_that("buildLdEigen reconstructs the correlation it was given", { + ld <- makeTestLdData(n = 6L) + block <- getEigenList(buildLdEigen(ld))[[1]] + rebuilt <- block$vectors %*% diag(block$values) %*% t(block$vectors) + expect_equal(rebuilt, unname(getCorrelation(ld)), tolerance = 1e-10) +}) + +test_that("buildLdEigen carries variant identity across from the LdData", { + ref <- buildLdEigen(makeTestLdData(n = 6L)) + md <- S4Vectors::mcols(ref, use.names = FALSE) + + # An LdData names variants `variant_id` and reports `allele_freq`; an + # LdStatistic wants SNP and MAF. + expect_equal(names(ref)[[1]], "chr1:1000:C:T") + expect_equal(as.character(md$A1)[[1]], "T") + expect_equal(as.character(md$A2)[[1]], "C") + expect_equal( + md$MAF, + pmin(seq(0.2, 0.8, length.out = 6), seq(0.8, 0.2, length.out = 6)) + ) +}) + +test_that("buildLdEigen truncates to the requested eigenvalue mass", { + ld <- makeTestLdData(n = 6L) + full <- getEigenList(buildLdEigen(ld))[[1]] + cut <- getEigenList(buildLdEigen(ld, eigenvalueTruncation = 0.9))[[1]] + + expect_equal(length(full$values), 6L) + expect_lt(length(cut$values), 6L) + expect_equal(ncol(cut$vectors), length(cut$values)) + # The retained components are the leading ones, unchanged. + expect_equal(cut$values, full$values[seq_along(cut$values)]) +}) + +test_that("buildLdEigen prefers an explicit nRef, inSample and genome", { + ref <- buildLdEigen( + makeTestLdData(), + nRef = 12345L, + inSample = TRUE, + genome = "hg38" + ) + expect_equal(getNRef(ref), 12345L) + expect_true(getInSample(ref)) + expect_equal(getGenome(ref), "hg38") +}) + + +test_that("eigenvalue truncation keeps everything when there is no mass", { + # All-nonpositive eigenvalues carry no cumulative mass to threshold + # against, so every index is kept rather than none. + expect_equal(pecotmr:::.ldEigenKeep(c(0, -1, -2), 0.9), 1:3) + # ...and a truncation of 1 keeps everything by definition. + expect_equal(pecotmr:::.ldEigenKeep(c(3, 2, 1), 1), 1:3) +}) diff --git a/tests/testthat/test_LdScore.R b/tests/testthat/test_LdScore.R index b5a48d28..edad43ae 100644 --- a/tests/testthat/test_LdScore.R +++ b/tests/testthat/test_LdScore.R @@ -111,3 +111,70 @@ test_that("validity requires the score columns to be present in mcols", { S4Vectors::mcols(bad)$ldScoreWeights <- NULL expect_error(methods::validObject(bad), "ldScoreWeights") }) + + +# ============================================================================= +# buildLdScore +# ============================================================================= + +test_that("buildLdScore computes per-block sums of r^2", { + ld <- makeTestLdData(n = 6L) + ref <- buildLdScore(ld) + + expect_s4_class(ref, "LdScore") + expect_equal(length(ref), 6L) + expect_equal(colnames(getLdScores(ref)), "base_l2") + expect_equal( + as.vector(getLdScores(ref)[, 1]), + rowSums(unname(getCorrelation(ld))^2) + ) +}) + +test_that("buildLdScore scores each block against only its own variants", { + ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) + scores <- as.vector(getLdScores(buildLdScore(ld))[, 1]) + perBlock <- unlist(lapply(getCorrelation(ld), function(R) rowSums(R^2))) + + expect_equal(length(scores), 7L) + expect_equal(scores, perBlock) +}) + +# buildLdScore and computeLdScores(LdEigen) are two routes to the same +# quantity -- sum_k r^2_jk versus sum_i V[j,i]^2 d[i]^2 -- so a disagreement +# means one of them has drifted. +test_that("buildLdScore agrees with computeLdScores on the same reference", { + for (ld in list(makeTestLdData(n = 6L), makeTestLdDataMultiBlock())) { + expect_equal( + as.vector(getLdScores(buildLdScore(ld))[, 1]), + as.vector(computeLdScores(buildLdEigen(ld))[, 1]) + ) + } +}) + +test_that("buildLdScore keeps per-block LD matrices for g-LDSC by default", { + ld <- makeTestLdDataMultiBlock(sizes = c(4L, 3L)) + mats <- getLdMatrixList(buildLdScore(ld)) + + expect_equal(length(mats), 2L) + expect_equal(dim(mats[[1]]$R), c(4L, 4L)) + expect_equal(mats[[1]]$snpIdx, 1:4) + expect_equal(mats[[2]]$snpIdx, 5:7) + expect_equal( + length(getLdMatrixList(buildLdScore(ld, keepLdMatrices = FALSE))), + 0L + ) +}) + +test_that("buildLdScore defaults weights to 1/max(l2, 1)", { + ld <- makeTestLdData(n = 6L) + ref <- buildLdScore(ld) + l2 <- as.vector(getLdScores(ref)[, 1]) + expect_equal(getLdScoreWeights(ref), 1 / pmax(l2, 1)) + + custom <- buildLdScore(ld, ldScoreWeights = rep(2, 6)) + expect_equal(getLdScoreWeights(custom), rep(2, 6)) + expect_error( + buildLdScore(ld, ldScoreWeights = rep(2, 3)), + "3 value\\(s\\) for 6 variant\\(s\\)" + ) +}) diff --git a/tests/testthat/test_LdStatistic.R b/tests/testthat/test_LdStatistic.R index ced212ec..f829bf3f 100644 --- a/tests/testthat/test_LdStatistic.R +++ b/tests/testthat/test_LdStatistic.R @@ -126,3 +126,276 @@ test_that("getLdBlocks returns the blocks the statistic was built against", { expect_s4_class(getLdBlocks(obj), "GRanges") expect_equal(length(getLdBlocks(obj)), 2L) }) + + +# ============================================================================= +# .ldRefPrepare -- the input handling shared by buildLdEigen/buildLdScore +# ============================================================================= + +test_that("the builders accept a bare LdData as well as a list of them", { + one <- makeTestLdData(n = 4L, startBp = 1000L) + two <- makeTestLdData(n = 3L, startBp = 5000L) + + expect_equal(length(buildLdEigen(one)), 4L) + expect_equal(length(buildLdEigen(list(one))), 4L) + + # A list of LdData concatenates: one LD block per element here, and the + # variant order follows the list order. + joined <- buildLdEigen(list(one, two)) + expect_equal(length(joined), 7L) + expect_equal(length(getEigenList(joined)), 2L) + expect_equal(getEigenList(joined)[[2]]$snpIdx, 5:7) +}) + +test_that("the builders reject input that is not LdData", { + expect_error(buildLdEigen("not-ld"), "must be an LdData") + expect_error(buildLdEigen(list()), "must be an LdData") + expect_error( + buildLdScore(list(makeTestLdData(), "not-ld")), + "element\\(s\\) 2 are not LdData" + ) +}) + +test_that("nRef is taken from the LdData, and disagreement is an error", { + a <- makeTestLdData(n = 4L, nRef = 500L) + b <- makeTestLdData(n = 3L, startBp = 5000L, nRef = 900L) + + expect_equal(getNRef(buildLdEigen(list(a, a))), 500L) + expect_error(buildLdEigen(list(a, b)), "differing reference panel sizes") + # An explicit nRef settles it. + expect_equal(getNRef(buildLdEigen(list(a, b), nRef = 700L)), 700L) +}) + +test_that("the genome build comes from the LdData when the caller names none", { + ld <- makeTestLdData() + # loadLdMatrix() leaves the build unset, which must stay NA rather than + # becoming a made-up default. + expect_true(is.na(getGenome(buildLdEigen(ld)))) + + tagged <- ld + GenomeInfoDb::genome(tagged) <- "hg38" + expect_equal(getGenome(buildLdEigen(tagged)), "hg38") + # An explicit argument still wins. + expect_equal(getGenome(buildLdEigen(tagged, genome = "hg19")), "hg19") +}) + +test_that("LD block ranges span the variants each block covers", { + ref <- buildLdEigen(makeTestLdDataMultiBlock(sizes = c(4L, 3L))) + blocks <- getLdBlocks(ref) + variants <- GenomicRanges::start(ref) + + expect_equal( + as.character(GenomicRanges::seqnames(blocks)), + c("chr1", "chr1") + ) + expect_equal(GenomicRanges::start(blocks), c(variants[[1]], variants[[5]])) + expect_equal(GenomicRanges::end(blocks), c(variants[[4]], variants[[7]])) +}) + +test_that("an LD block spanning chromosomes is rejected", { + ld <- makeTestLdData(n = 4L) + gr <- as(ld, "GRanges") + GenomeInfoDb::seqlevels(gr) <- c("chr1", "chr2") + GenomicRanges::seqnames(gr) <- factor( + c("chr1", "chr1", "chr2", "chr2"), + levels = c("chr1", "chr2") + ) + crossChrom <- LdData( + correlation = getCorrelation(ld), + variants = gr, + blockMetadata = getBlockMetadata(ld), + nRef = getNRef(ld) + ) + expect_error(buildLdEigen(crossChrom), "spans 2 chromosomes") +}) + +# =========================================================================== +# .ldRefPrepare()'s accessor fallbacks and guards +# +# The shared helpers behind buildLdEigen() / buildLdScore() read a variant's +# identity, alleles and frequency out of whatever columns the LdData happens +# to carry. Every fixture above supplies `variant_id` + `allele_freq` and a +# blockMetadata whose startIdx/endIdx line up, so only one path through each +# accessor was ever taken. These exercise the others. +# =========================================================================== + +# An LdData whose variant metadata is whatever the caller passes, so each +# accessor branch can be reached in turn. `blockMetadata` defaults to a +# single block spanning every variant. +.ldsVariants <- function(n, md = NULL, variantNames = NULL) { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = seq(100L, by = 100L, length.out = n), + width = 1L + ) + ) + if (is.null(md)) { + md <- S4Vectors::DataFrame( + variant_id = str_c("v", seq_len(n)), + A1 = rep("T", n), + A2 = rep("C", n) + ) + } + S4Vectors::mcols(gr) <- md + if (!is.null(variantNames)) { + names(gr) <- variantNames + } + gr +} + +.ldsBlockMeta <- function(sizes) { + ends <- cumsum(sizes) + starts <- ends - sizes + 1L + tibble( + blockId = seq_along(sizes), + chrom = "1", + blockStart = as.integer(100L * starts), + blockEnd = as.integer(100L * ends), + size = as.integer(sizes), + startIdx = as.integer(starts), + endIdx = as.integer(ends) + ) +} + +.ldsData <- function( + n = 3L, + md = NULL, + variantNames = NULL, + nRef = 100L, + correlation = NULL, + blockMetadata = NULL +) { + LdData( + correlation = correlation %||% diag(n), + variants = .ldsVariants(n, md, variantNames), + blockMetadata = blockMetadata %||% .ldsBlockMeta(n), + nRef = nRef + ) +} + +.ldsAlleles <- function(n) { + S4Vectors::DataFrame(A1 = rep("T", n), A2 = rep("C", n)) +} + +test_that("variant ids fall back to a SNP column when there is no variant_id", { + md <- S4Vectors::DataFrame( + SNP = c("s1", "s2", "s3"), + A1 = rep("T", 3), + A2 = rep("C", 3) + ) + expect_equal(names(buildLdScore(.ldsData(3L, md))), c("s1", "s2", "s3")) +}) + +test_that("variant ids fall back to the GRanges names", { + expect_equal( + names(buildLdScore( + .ldsData(3L, .ldsAlleles(3L), variantNames = c("n1", "n2", "n3")) + )), + c("n1", "n2", "n3") + ) +}) + +test_that("variant ids are synthesized from chrom:pos as a last resort", { + expect_equal( + names(buildLdScore(.ldsData(3L, .ldsAlleles(3L)))), + c("chr1:100", "chr1:200", "chr1:300") + ) +}) + +test_that("an MAF column is carried across as-is", { + md <- S4Vectors::DataFrame( + variant_id = c("a", "b", "c"), + A1 = rep("T", 3), + A2 = rep("C", 3), + MAF = c(0.1, 0.2, 0.3) + ) + got <- S4Vectors::mcols(buildLdScore(.ldsData(3L, md)), use.names = FALSE) + expect_true(is_in("MAF", colnames(got))) + # Taken verbatim, NOT folded the way allele_freq is. + expect_equal(as.numeric(got$MAF), c(0.1, 0.2, 0.3)) +}) + +test_that("no frequency column leaves the MAF column off entirely", { + got <- S4Vectors::mcols( + buildLdScore(.ldsData(3L, .ldsAlleles(3L))), + use.names = FALSE + ) + expect_false(is_in("MAF", colnames(got))) +}) + +test_that("blocks are taken in order when blockMetadata has no startIdx", { + # The positional fallback: each block covers as many variants as its + # matrix has rows. blockMetadata is present but carries no index columns, + # so it cannot be treated as authoritative. + noIdx <- tibble( + blockId = 1:2, + chrom = "1", + blockStart = c(100L, 300L), + blockEnd = c(200L, 400L), + size = c(2L, 2L) + ) + ref <- buildLdScore(.ldsData( + 4L, + correlation = list(diag(2), diag(2)), + blockMetadata = noIdx + )) + expect_equal(length(ref), 4L) + expect_equal(length(getLdBlocks(ref)), 2L) +}) + +test_that("a variant table with no A1 column is rejected", { + md <- S4Vectors::DataFrame( + variant_id = c("a", "b", "c"), + A2 = rep("C", 3) + ) + expect_error( + buildLdScore(.ldsData(3L, md)), + "carry no `A1` column" + ) +}) + +test_that("block matrices that do not cover every variant are rejected", { + expect_error( + buildLdScore(.ldsData( + 3L, + correlation = list(diag(2), diag(2)), + blockMetadata = .ldsBlockMeta(c(2L, 2L)) + )), + "cover 4 variant\\(s\\) but the LdData carries 3" + ) +}) + +test_that("a block matrix sized differently from its span is rejected", { + # sum(sizes) matches the variant count, so the earlier total check passes; + # the mis-span only shows up once each block is sliced out. + misSpan <- tibble( + blockId = 1:2, + chrom = "1", + blockStart = c(100L, 400L), + blockEnd = c(300L, 400L), + size = c(3L, 1L), + startIdx = c(1L, 4L), + endIdx = c(3L, 4L) + ) + expect_error( + buildLdScore(.ldsData( + 4L, + correlation = list(diag(2), diag(2)), + blockMetadata = misSpan + )), + "correlation matrix is 2x2 but covers 3 variant" + ) +}) + +test_that("nRef is required when no LdData records one", { + expect_error( + buildLdScore(.ldsData(3L, nRef = NA_integer_)), + "`nRef` is required" + ) +}) + +test_that("an explicit nRef overrides a missing one", { + ref <- buildLdScore(.ldsData(3L, nRef = NA_integer_), nRef = 250L) + expect_equal(getNRef(ref), 250L) +}) diff --git a/tests/testthat/test_MashPrior.R b/tests/testthat/test_MashPrior.R index e2c04b9d..753390ab 100644 --- a/tests/testthat/test_MashPrior.R +++ b/tests/testthat/test_MashPrior.R @@ -72,3 +72,23 @@ test_that("MashPrior: show reports 'cvFits: none' for a full-only bundle", { expect_true(any(grepl("cvFits: none", out))) expect_true(any(grepl("fullFit: present", out))) }) + + +test_that("the cvFits check rejects a list with no perFoldFits", { + f <- pecotmr:::.mashPriorCheckCvFits + msg <- "`cvFits` must be a list with a `perFoldFits` element" + expect_equal(f(list(somethingElse = 1)), msg) + expect_equal(f("not a list"), msg) + # NULL is the "no CV was run" case and is accepted. + expect_null(f(NULL)) +}) + + +test_that("the partition check stops when perFoldFits is not a list", { + # The fold-count comparison below it would be meaningless, and the + # perFoldFits check already reports the type problem. + expect_null(pecotmr:::.mashPriorCheckPartition(list( + perFoldFits = "not a list", + samplePartition = data.frame(Sample = "a", Fold = 1L) + ))) +}) diff --git a/tests/testthat/test_MultiStudyQtlDataset.R b/tests/testthat/test_MultiStudyQtlDataset.R index e30bd755..769cd4ef 100644 --- a/tests/testthat/test_MultiStudyQtlDataset.R +++ b/tests/testthat/test_MultiStudyQtlDataset.R @@ -156,3 +156,62 @@ test_that("getSumStats(MultiStudyQtlDataset) rejects selection arguments", { # ... but any selection argument is rejected. expect_error(getSumStats(mt, study = "s1"), "does not accept selection") }) + + +# =========================================================================== +# Validity branches +# +# Every construction above builds a VALID object, so the message-returning +# arms of the checks were never reached. +# =========================================================================== + +test_that("MultiStudyQtlDataset: rejects an empty qtlDatasets list", { + expect_error( + MultiStudyQtlDataset(qtlDatasets = list()), + "'qtlDatasets' must be a non-empty named list" + ) +}) + +test_that("MultiStudyQtlDataset: rejects duplicated study names", { + qd <- QtlDataset( + study = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = .sc_makeSe()) + ) + expect_error( + MultiStudyQtlDataset(qtlDatasets = list(s1 = qd, s1 = qd)), + "names of 'qtlDatasets' must be unique" + ) +}) + +test_that("MultiStudyQtlDataset: rejects a non-QtlSumStats sumStats", { + qd <- QtlDataset( + study = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = .sc_makeSe()) + ) + expect_error( + MultiStudyQtlDataset( + qtlDatasets = list(s1 = qd, s2 = qd), + sumStats = "not a QtlSumStats" + ), + "'sumStats' must be a QtlSumStats object or NULL" + ) +}) + + +test_that("getStudy unions the individual-level and summary-only studies", { + # The sumStats arm was never taken: every collection built above carries + # only QtlDatasets, so getStudy() only ever read their names. + data(qtlSumStatsExample) + qd <- QtlDataset( + study = "s1", + genotypes = .sc_makeGenotypeHandle(), + phenotypes = list(brain = .sc_makeSe()) + ) + mt <- MultiStudyQtlDataset( + qtlDatasets = list(s1 = qd), + sumStats = qtlSumStatsExample + ) + expect_setequal(getStudy(mt), c("s1", "study1")) +}) diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index 8568e4f8..f839ee52 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -2942,6 +2942,57 @@ test_that("subsetting by context keeps the genotype experiment", { expect_true(validObject(out)) }) +test_that("subsetting by sample and context together narrows both axes", { + # `x[, j, k]`: the experiment axis is applied here, then the remaining + # axes go back through the method with no `k` so the inherited one runs. + qd <- .qm_makeDataset() + out <- suppressWarnings(suppressMessages(qd[, paste0("s", 1:5), "brain"])) + expect_s4_class(out, "QtlDataset") + expect_equal(getContexts(out), "brain") + expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) + expect_true(validObject(out)) +}) + +test_that("subsetting by feature and context leaves the samples alone", { + # `x[i, , k]`: no sample subscript, so every sample survives. + qd <- .qm_makeDataset() + out <- suppressWarnings(suppressMessages(qd[1, , "brain"])) + expect_s4_class(out, "QtlDataset") + expect_equal(getContexts(out), "brain") + expect_equal(nrow(MultiAssayExperiment::colData(out)), 12L) + expect_true(validObject(out)) +}) + +test_that("all three subscripts can be given at once", { + qd <- .qm_makeDataset() + out <- suppressWarnings(suppressMessages( + qd[1, paste0("s", 1:5), "brain"] + )) + expect_s4_class(out, "QtlDataset") + expect_equal(getContexts(out), "brain") + expect_equal(nrow(MultiAssayExperiment::colData(out)), 5L) + expect_true(validObject(out)) +}) + +test_that("the experiment subscript accepts logical and numeric, not just names", { + qd <- .qm_makeDataset() + nms <- names(MultiAssayExperiment::experiments(qd)) + expect_equal(nms, c("genotype", "brain", "liver")) + expect_equal(pecotmr:::.qtlExperimentIndex("brain", nms), 2L) + expect_equal( + pecotmr:::.qtlExperimentIndex(c(TRUE, TRUE, FALSE), nms), + c(1L, 2L) + ) + expect_equal(pecotmr:::.qtlExperimentIndex(c(1, 2), nms), c(1L, 2L)) +}) + +test_that("a logical experiment subscript recycles over the experiments", { + # rep(k, length.out =) is what makes a short logical usable at all. + nms <- c("genotype", "brain", "liver") + expect_equal(pecotmr:::.qtlExperimentIndex(TRUE, nms), c(1L, 2L, 3L)) + expect_equal(pecotmr:::.qtlExperimentIndex(c(TRUE, FALSE), nms), c(1L, 3L)) +}) + test_that("subsetting to no context at all is an error", { qd <- .qm_makeDataset() expect_error(qd[,, "genotype"], "selects no QTL context") @@ -3093,3 +3144,113 @@ test_that("QtlDataset still rejects a genotype source it cannot open", { "must be a genotype panel" ) }) + + +# =========================================================================== +# Validity and guard branches +# +# Every construction elsewhere in this file builds a VALID object, so the +# message-returning arms of the checks and the two sample-intersection +# guards were never executed. +# =========================================================================== + +test_that("validity rejects a non-scalar scaleResiduals", { + # The constructor coerces via isTRUE(); validity guards direct slot sets. + qd <- .qh_makeDataset() + qd@scaleResiduals <- c(TRUE, FALSE) + expect_error(validObject(qd), "scaleResiduals.*single logical") +}) + +test_that("the phenotype-list check rejects duplicated context names", { + se <- .qh_makeSe() + errs <- pecotmr:::.qtlCheckPhenotypeList(list(brain = se, brain = se)) + expect_true(any(str_detect( + errs, + "context names in 'phenotypes' must be unique" + ))) +}) + +test_that("the phenotype check reports a missing genotype experiment", { + # Reached with a bare MultiAssayExperiment: a QtlDataset that had lost the + # genotype experiment would fail MAE's own validity first. + mae <- MultiAssayExperiment::MultiAssayExperiment( + experiments = list(brain = .qh_makeSe()) + ) + expect_equal( + pecotmr:::.qtlValidatePhenotypes(mae), + "experiment 'genotype' is missing" + ) +}) + +test_that("the phenotype check reports an empty context set", { + qd <- .qh_makeDataset() + gse <- MultiAssayExperiment::experiments(qd)[["genotype"]] + mae <- MultiAssayExperiment::MultiAssayExperiment( + experiments = list(genotype = gse) + ) + expect_equal( + pecotmr:::.qtlValidatePhenotypes(mae), + "'phenotypes' must not be empty" + ) +}) + +test_that("aligning genotypes and covariates errors when they share no samples", { + G <- matrix(0, 2L, 2L, dimnames = list(c("a", "b"), c("v1", "v2"))) + C <- matrix(0, 2L, 1L, dimnames = list(c("x", "y"), "pc1")) + expect_error( + pecotmr:::.qtlAlignGC(G, C, contexts = "brain"), + "No samples in common between the genotype matrix" + ) + # ...and a NULL covariate matrix is a no-op rather than an error. + expect_equal(pecotmr:::.qtlAlignGC(G, NULL, "brain"), list(G = G, C = NULL)) +}) + +test_that("residualizing a context errors when covariates share no samples", { + se <- .qh_makeSe() + C <- matrix( + 0, + 2L, + 1L, + dimnames = list(c("nobody1", "nobody2"), "pc1") + ) + expect_error( + pecotmr:::.qtlResidualizeContextPheno( + se, + C, + ctx = "brain", + outlierAction = "none", + outlierPvalThreshold = 1, + scaleResiduals = FALSE + ), + "context 'brain': no samples shared" + ) +}) + + +test_that("trait-position validation skips a context whose ranges do not line up", { + # rowRanges and rownames disagreeing means the context cannot be compared + # against the others; it is skipped rather than reported as a conflict. + mkSe <- function(traits) { + SummarizedExperiment::SummarizedExperiment( + assays = list( + x = matrix( + 0, + length(traits), + 2L, + dimnames = list(traits, c("s1", "s2")) + ) + ) + ) + } + mae <- MultiAssayExperiment::MultiAssayExperiment( + experiments = list( + brain = mkSe(c("t1", "t2")), + liver = mkSe(c("t1", "t2")) + ) + ) + expect_equal(pecotmr:::.qtlValidateTraitPositions(mae), character(0)) +}) + +test_that("aligning covariates with nothing to align returns NULL", { + expect_null(pecotmr:::.qtlAlignCovariates(list(), NULL)) +}) diff --git a/tests/testthat/test_RangedTupleList.R b/tests/testthat/test_RangedTupleList.R index 38798fda..1374e47b 100644 --- a/tests/testthat/test_RangedTupleList.R +++ b/tests/testthat/test_RangedTupleList.R @@ -812,3 +812,33 @@ test_that(".rtlTupleKeyCols is empty when there are no mcols", { gr <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 2)) expect_equal(.rtlTupleKeyCols(gr), character(0)) }) + + +test_that("`[[<-` rejects a non-scalar or NA index", { + x <- .rtl_makeKid() + expect_error(x[[c(1L, 2L)]] <- x[[1L]], "takes a single non-NA index") + expect_error(x[[NA_integer_]] <- x[[1L]], "takes a single non-NA index") +}) + + +test_that("range keys of an empty collection are empty", { + expect_equal( + pecotmr:::.rtlRangeKeys(GenomicRanges::GRangesList()), + character(0) + ) +}) + +test_that("seqinfo is left alone when the source carries none", { + # Nothing to restore from, so the rebuild is returned untouched. + empty <- new( + "RtlTestKid", + GenomicRanges::GRangesList(), + genome = "hg38", + ldSketch = NULL, + qcInfo = list() + ) + grl <- GenomicRanges::GRangesList( + a = GenomicRanges::GRanges("chr1", IRanges::IRanges(100L, width = 1L)) + ) + expect_identical(pecotmr:::.rtlRestoreSeqinfo(grl, empty), grl) +}) diff --git a/tests/testthat/test_SldscData.R b/tests/testthat/test_SldscData.R index b89cba3a..cfeb02d2 100644 --- a/tests/testthat/test_SldscData.R +++ b/tests/testthat/test_SldscData.R @@ -78,9 +78,9 @@ test_that("getAnnotCols returns the annotation columns only", { expect_equal(getAnnotCols(sd), c("annot_A", "annot_B")) }) -test_that("getTraitRuns / getTraitNames expose the traits list", { +test_that("getTraitRuns / getTraits expose the traits list", { sd <- .sldscMkData() - expect_equal(getTraitNames(sd), c("traitX", "traitY")) + expect_equal(getTraits(sd), c("traitX", "traitY")) expect_named(getTraitRuns(sd), c("traitX", "traitY")) }) @@ -112,3 +112,12 @@ test_that("show prints a compact summary", { expect_true(any(grepl("annot_A, annot_B", out))) expect_true(any(grepl("traitX, traitY", out))) }) + + +test_that("a trait whose `single` is not a list is rejected", { + tr <- list(traitA = list(single = "not a list")) + expect_match( + pecotmr:::.sldscDataCheckOneTrait("traitA", tr), + "traits\\[\\['traitA'\\]\\]\\$single must be a list of runs" + ) +}) diff --git a/tests/testthat/test_causalInferencePipeline.R b/tests/testthat/test_causalInferencePipeline.R index f236acd6..05044a2d 100644 --- a/tests/testthat/test_causalInferencePipeline.R +++ b/tests/testthat/test_causalInferencePipeline.R @@ -1147,12 +1147,12 @@ test_that("twasZ: error when weights and z have different lengths", { ) }) -# Phase 2: loadLdSketch() and standardize_genotype_hwe() +# Phase 2: LD-sketch loading and standardize_genotype_hwe() # =========================================================================== # Direct unit tests for the MR / metric helpers (mock getTopLoci to feed # controlled topLoci frames; gwasDf is a plain data.frame as produced by -# getSumstatDf upstream). +# getSumStatsDf upstream). # =========================================================================== .cip_gwasDf <- function( @@ -1626,3 +1626,233 @@ test_that(".cipPairLabel: names both sides of the pair", { expect_true(grepl("trait='t1'", label, fixed = TRUE)) expect_true(grepl("study='G1'", label, fixed = TRUE)) }) + + +# =========================================================================== +# Column indexing, CV metric lookup and V alignment +# =========================================================================== + +test_that("an absent GWAS column fills NA rather than dropping rows", { + # The result table has one row per requested index either way, so a + # missing optional column must not shorten it. + expect_equal(pecotmr:::.cipGwasCol(NULL, c(1L, 2L)), c(NA_real_, NA_real_)) + expect_equal(pecotmr:::.cipGwasCol(c(9, 8, 7), c(1L, 3L)), c(9, 7)) +}) + +test_that("a tuple with no CV record scores NA", { + # NA, not 0: no cross-validation was run, which is different from a fit + # that cross-validated badly. + expect_true(is.na(pecotmr:::.cipCvMetric( + NULL, + "s", + "c", + "t", + "m", + which = "rsq" + ))) +}) + +test_that("V is aligned to the weight names, and refuses to guess", { + V <- matrix(1:6, 3L, 2L, dimnames = list(c("a", "b", "c"), NULL)) + # Named alignment reorders rather than assuming position. + aligned <- pecotmr:::.twasZAlignV(V, c("c", "a"), 2L) + expect_equal(dim(aligned), c(2L, 2L)) + expect_equal(unname(aligned[, 1L]), c(3L, 1L)) + expect_equal(rownames(aligned), c("c", "a")) + # A weight variant with no row in V is an error, not a silent drop. + expect_error( + pecotmr:::.twasZAlignV(V, "zz", 1L), + "V is missing rows for 1 variant" + ) +}) + + +# =========================================================================== +# Method selection and the CS-aware MR composite +# =========================================================================== + +test_that("selecting the best method over an empty frame is a no-op", { + df0 <- tibble( + qtlStudy = character(0), + context = character(0), + trait = character(0), + method = character(0), + gwasStudy = character(0), + twasZ = numeric(0) + ) + expect_equal(nrow(pecotmr:::.cipSelectBestMethod(df0, c(a = 1))), 0L) +}) + +test_that("a credible set below the cumulative-PIP cutoff contributes nothing", { + # cpip is the SUM of member PIPs; a set that does not reach the cutoff is + # dropped rather than contributing a poorly-supported Wald ratio. + inst <- tibble( + cs = c("L1", "L1"), + pip = c(0.1, 0.1), + bhatX = c(2, 2), + sbhatX = c(0.1, 0.1), + bhatY = c(1, 2), + sbhatY = c(0.1, 0.1) + ) + expect_null(pecotmr:::.cipCsComposite("L1", inst, 0.5)) + # A set id that matches nothing has cpip 0 and is likewise dropped. + expect_null(pecotmr:::.cipCsComposite("L9", inst, 0.5)) +}) + +test_that("a zero exposure effect yields no composite rather than infinity", { + # by/bx is the Wald ratio; bx == 0 makes it non-finite, so the set is + # dropped instead of propagating Inf into the IVW pooling. + inst <- tibble( + cs = c("L1", "L1"), + pip = c(0.5, 0.5), + bhatX = c(0, 0), + sbhatX = c(0.1, 0.1), + bhatY = c(1, 2), + sbhatY = c(0.1, 0.1) + ) + expect_null(pecotmr:::.cipCsComposite("L1", inst, 0.5)) +}) + +test_that("a well-supported credible set yields a finite composite", { + inst <- tibble( + cs = c("L1", "L1"), + pip = c(0.5, 0.5), + bhatX = c(2, 2), + sbhatX = c(0.1, 0.1), + bhatY = c(1, 2), + sbhatY = c(0.1, 0.1) + ) + out <- pecotmr:::.cipCsComposite("L1", inst, 0.5) + expect_true(is.finite(out$bhat)) + expect_gt(out$sbhat, 0) +}) + +# --------------------------------------------------------------------------- +# Work-list and scoring guards: the pipeline refuses to return an empty result +# silently, and a tuple that cannot be scored drops out rather than erroring. +# --------------------------------------------------------------------------- + +test_that(".cipResolveWorkList rejects empty weight collections", { + local_mocked_bindings( + .cipBuildQtlWorkList = function(twasWeights, fineMappingResult) { + data.frame() + }, + .package = "pecotmr" + ) + expect_error( + pecotmr:::.cipResolveWorkList(NULL, NULL), + "no QTL tuples to score" + ) +}) + +test_that(".cipCvSelection errors when no method clears the CV cutoffs", { + local_mocked_bindings( + .cipMethodMetrics = function(...) { + data.frame( + qtlStudy = "s", context = "c", trait = "t", + method = "m", rsq = 0.01, stringsAsFactors = FALSE + ) + }, + .cipFilterEligibleMethods = function(...) data.frame(), + .package = "pecotmr" + ) + p <- list( + twasWeights = "notNull", rsqCutoff = 0.5, rsqPvalCutoff = 0.05, + qtlRows = data.frame(a = 1), rsqOption = NULL, rsqPvalOption = NULL + ) + # Naming the cutoffs in the message is what makes this actionable. + expect_error( + pecotmr:::.cipCvSelection(p), + "rsqCutoff = 0.5 / rsqPvalCutoff = 0.05" + ) +}) + +test_that(".cipRun errors when no tuple produced a result", { + local_mocked_bindings( + .cipValidateInputs = function(...) invisible(NULL), + .cipCheckLdSketches = function(...) NULL, + .cipResolveWorkList = function(...) data.frame(x = 1), + .cipCvSelection = function(p) { + list( + qtlRows = data.frame(x = 1), + rsqLookup = NULL, + selectionActive = FALSE + ) + }, + .cipScoreQtlTuple = function(qi, p) list(), + .package = "pecotmr" + ) + expect_error( + pecotmr:::.cipRun(list()), + "no \\(qtl, gwas\\) tuples produced a result" + ) +}) + +test_that(".cipScoreQtlTuple skips a tuple with no weights", { + local_mocked_bindings( + .cipExtractWeights = function(...) NULL, + .package = "pecotmr" + ) + p <- list( + qtlRows = data.frame( + qtlStudy = "s", context = "c", trait = "t", method = "m", + useFmrForWeights = FALSE, stringsAsFactors = FALSE + ), + twasWeights = NULL, + fineMappingResult = NULL + ) + # An empty list contributes no rows once flattened. + expect_identical(pecotmr:::.cipScoreQtlTuple(1L, p), list()) +}) + +test_that(".cipScoreGwasPair skips a pair with no TWAS z", { + local_mocked_bindings( + getSumStatsDf = function(...) data.frame(SNP = "v1", Z = 1), + .cipComputeTwasZ = function(...) NULL, + .cipPairLabel = function(...) "lab", + .package = "pecotmr" + ) + p <- list(gwasSumStats = list(study = "G1"), gwasLd = NULL, + alleleFlip = FALSE) + expect_null( + pecotmr:::.cipScoreGwasPair(1L, NULL, list(), NULL, p) + ) +}) + +test_that(".cipRunMr routes to the CS-aware estimator when asked", { + local_mocked_bindings( + .cipComputeMrCsAware = function(...) list(SENTINEL = TRUE), + .package = "pecotmr" + ) + p <- list( + mrPvalCutoff = 1, mrMethod = "csAware", + mrCpipCutoff = 0.5, alleleFlip = FALSE + ) + out <- pecotmr:::.cipRunMr( + fmrEntry = "notNull", + gdf = NULL, + twasOut = list(pval = 0.001), + p = p + ) + expect_true(isTRUE(out$SENTINEL)) +}) + +test_that(".cipCvMetric reads metrics wrapped or bare, NA when absent", { + local_mocked_bindings( + getCvResult = function(...) list(rsq = 0.42, pval = 0.01), + .package = "pecotmr" + ) + # A bare metrics list (no $metrics wrapper) is read directly. + expect_equal(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq"), 0.42) + expect_true(is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "zzz"))) +}) + +test_that(".cipCvMetric returns NA when the CV result cannot be read", { + local_mocked_bindings( + getCvResult = function(...) stop("nope"), + .package = "pecotmr" + ) + expect_true( + is.na(pecotmr:::.cipCvMetric(NULL, "s", "c", "t", "m", "rsq")) + ) +}) diff --git a/tests/testthat/test_colocPipeline.R b/tests/testthat/test_colocPipeline.R index d0d42ce4..dac04fda 100644 --- a/tests/testthat/test_colocPipeline.R +++ b/tests/testthat/test_colocPipeline.R @@ -1205,3 +1205,65 @@ test_that("colocPipeline publishes coloc's variant count as nSnps", { already <- data.frame(nSnps = 7L) expect_equal(.colocRenameNsnps(already)$nSnps, 7L) }) + + +test_that("an explicit blockId is preferred over the derived range key", { + # blockId keys the external block manifest, so it carries the true block + # BOUNDARIES rather than the span of whichever variants survived QC. + data(gwasFineMappingExample) + expect_equal( + pecotmr:::.colocGwasBlockIds(gwasFineMappingExample), + "region_1" + ) + # Without the column the identity falls back to the variant span. + g <- gwasFineMappingExample + S4Vectors::mcols(g)$blockId <- NULL + expect_equal( + pecotmr:::.colocGwasBlockIds(g), + pecotmr:::.rtlRangeKeys(g) + ) + expect_match(pecotmr:::.colocGwasBlockIds(g), "^chr22_") +}) + +test_that("an enrichment axis neither side has matches on NA", { + # `==` evaluates to NA against an absent axis, which would drop every row; + # the NA-wanted case has to match NA values explicitly instead. + f <- pecotmr:::.colocEnrichmentColumnMatches + enr <- data.frame(a = c("x", NA)) + expect_equal(f("a", enr, list(a = NA_character_)), c(FALSE, TRUE)) + expect_equal(f("a", enr, list(a = "x")), c(TRUE, FALSE)) +}) + + +test_that("PIP adjustment is skipped when either side has no rows", { + # Intersecting variants across an empty side would empty the other, so + # the inputs are passed through untouched instead. + data(qtlFineMappingExample, gwasFineMappingExample) + p <- list( + adjustPips = TRUE, + qtlFineMappingResult = qtlFineMappingExample[0], + gwasFmr = gwasFineMappingExample + ) + expect_identical(pecotmr:::.colocMaybeAdjustPips(p), p) + # ...and it is skipped outright when not requested. + p2 <- list( + adjustPips = FALSE, + qtlFineMappingResult = qtlFineMappingExample, + gwasFmr = gwasFineMappingExample + ) + expect_identical(pecotmr:::.colocMaybeAdjustPips(p2), p2) +}) + +test_that("pre-extracting LBF from an empty GWAS result yields no blocks", { + data(gwasFineMappingExample) + expect_equal( + pecotmr:::.colocPreextractGwasLbf( + gwasFineMappingExample[0], + FALSE, + FALSE, + FALSE, + 1e-9 + ), + list() + ) +}) diff --git a/tests/testthat/test_colocboostPipeline.R b/tests/testthat/test_colocboostPipeline.R index e154c5e9..e7e04aaa 100644 --- a/tests/testthat/test_colocboostPipeline.R +++ b/tests/testthat/test_colocboostPipeline.R @@ -972,7 +972,7 @@ test_that("colocboost sumstat bundle drops panel-rare variants", { test_that("colocboost RSS cutoffs match .panelVariantFilter", { ss <- .cbf_qcd() ids <- normalizeVariantId( - getSumstatDf( + getSumStatsDf( ss, study = ss$study[[1L]], context = ss$context[[1L]], @@ -1013,7 +1013,7 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { # filtered set has to be passed to the LD build separately rather than by # shrinking that vector. ss <- .cbf_qcd() - df <- getSumstatDf( + df <- getSumStatsDf( ss, study = ss$study[[1L]], context = ss$context[[1L]], @@ -1038,7 +1038,7 @@ test_that(".cbSumstatPair keeps sumstat rows aligned to the LD matrix", { test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { ss <- .cbf_qcd() - df <- getSumstatDf( + df <- getSumStatsDf( ss, study = ss$study[[1L]], context = ss$context[[1L]], @@ -1051,3 +1051,203 @@ test_that(".cbSumstatPair returns NULL when a cutoff removes everything", { cutoffs = list(mafCutoff = 0.99, macCutoff = 0, imissCutoff = 1) ))) }) + + +# =========================================================================== +# Outcome naming and canonical allele flipping +# =========================================================================== + +test_that("outcome names are defaulted, context-qualified and de-duplicated", { + # Three distinct problems: an unnamed column, the same trait appearing in + # two contexts, and a name that clashes with one already assigned. + f <- pecotmr:::.cbTraitName + expect_equal(f(NULL, "brain", character(0), c("a", "b")), "outcome3") + expect_equal(f("", "brain", character(0), "a"), "outcome2") + # Same trait in more than one context gets the context prefix. + expect_equal(f("G1", "brain", "G1", character(0)), "brain_G1") + # A clash with an already-assigned name is made unique. + expect_equal(f("G1", "brain", character(0), "G1"), "G1.1") + # Nothing to fix. + expect_equal(f("G1", "brain", character(0), character(0)), "G1") +}) + +test_that("flipping to canonical drops a matrix with no shared variants", { + # Zero columns but the sample rows preserved, so the result still binds + # against the other contexts rather than collapsing. + m <- matrix( + 1:4, + 2L, + 2L, + dimnames = list(NULL, c("chr9:1:A:G", "chr9:2:C:T")) + ) + out <- pecotmr:::.cbFlipMatrixToCanonical(m, "chr1:100:A:G") + expect_equal(dim(out), c(2L, 0L)) +}) + +test_that("flipping a sumstat/LD pair with no shared variants yields NULL", { + # NULL, not an empty pair: there is nothing to colocalize, and an empty + # sumstat would look like a fitted-but-null result. + pair <- list( + sumstat = tibble(variant = "chr9:1:A:G", z = 1), + LD = diag(1) + ) + expect_null(pecotmr:::.cbFlipPairToCanonical(pair, "chr1:100:A:G")) +}) + + +test_that("outcome info is the empty frame when nothing contributed", { + # Same shape as a populated one, so the downstream bind and join still + # work on a run that produced no outcomes. + out <- pecotmr:::.cbOutcomeInfo(list(), NULL, NULL) + expect_equal(nrow(out), 0L) + expect_equal( + colnames(out), + colnames(pecotmr:::.cbEmptyOutcomeInfo()) + ) +}) + +test_that("a MultiStudyQtlDataset with no embedded sumstats yields no pairs", { + # The sumstats arm is optional; its absence is an empty bundle rather + # than an error, so a purely individual-level collection still runs. + data(multiStudyQtlDatasetExample) + out <- pecotmr:::.cbMultiStudySumstats( + multiStudyQtlDatasetExample, + contexts = NULL, + traitId = NULL + ) + expect_equal(out$qtlPairs, list()) + expect_null(out$qtlLdSketch) +}) + +test_that("the signal screen passes Y through when no cutoff applies", { + # A NULL / absent screen spec means "do not screen", which is different + # from a screen that everything failed. + Y <- matrix(1:4, 2L, 2L, dimnames = list(c("s1", "s2"), c("t1", "t2"))) + expect_identical( + pecotmr:::.cbApplyScreen(NULL, Y, "brain", NULL), + Y + ) +}) + +# --------------------------------------------------------------------------- +# Per-context skips: a context that cannot supply usable X/Y drops out with an +# explanation, rather than reaching colocboost as an empty or misaligned pair. +# --------------------------------------------------------------------------- + +.cbp_mat <- function(rowNames, colNames) { + matrix( + 0, + nrow = length(rowNames), + ncol = length(colNames), + dimnames = list(rowNames, colNames) + ) +} + +test_that(".cbBuildContextXY skips a context with no genotypes", { + local_mocked_bindings( + .cbResidualizedY = function(...) .cbp_mat(c("s1", "s2"), "f1"), + .cbResidualizedX = function(...) NULL, + .package = "pecotmr" + ) + expect_null(pecotmr:::.cbBuildContextXY("c1", list())) +}) + +test_that(".cbBuildContextXY skips a context with no shared samples", { + local_mocked_bindings( + .cbResidualizedY = function(...) .cbp_mat(c("s1", "s2"), "f1"), + .cbResidualizedX = function(...) { + .cbp_mat(c("z9", "z8"), c("chr1:1:A:G", "chr1:2:C:T")) + }, + .package = "pecotmr" + ) + # X and Y are each non-empty, but they describe disjoint sample sets. + expect_message( + res <- pecotmr:::.cbBuildContextXY("c1", list()), + "no samples shared between residualized X and Y" + ) + expect_null(res) +}) + +test_that(".cbResidualizedX reports why genotypes were unavailable", { + local_mocked_bindings( + getResidualizedGenotypes = function(...) stop("kaboom"), + .package = "pecotmr" + ) + # The underlying message is carried through so the skip is diagnosable. + expect_message( + res <- pecotmr:::.cbResidualizedX( + NULL, "c1", NULL, NULL, NULL, NULL + ), + "residualized genotypes unavailable: kaboom" + ) + expect_null(res) +}) + +test_that(".cbApplyScreen keeps the outcomes that clear the screen", { + Y <- .cbp_mat(c("s1", "s2"), c("f1", "f2")) + local_mocked_bindings( + .cbPipSkipOutcomes = function(X, Y, cutoff) Y[, 1, drop = FALSE], + .package = "pecotmr" + ) + out <- pecotmr:::.cbApplyScreen(NULL, Y, "c1", 0.5) + expect_equal(ncol(out), 1L) + expect_equal(colnames(out), "f1") +}) + +test_that(".cbToResultObject skips a separate_gwas study that produced none", { + raw <- list( + xqtl_coloc = NULL, + joint_gwas = NULL, + separate_gwas = list(G1 = NULL, G2 = .cbr_fake()), + computing_time = list() + ) + x <- pecotmr:::.cbToResultObject(raw, .cbr_info()) + # G1 contributes no row at all; its key must not survive as an empty one. + expect_equal(nrow(x), 1L) + expect_equal(as.character(x$gwasStudy), "G2") + expect_equal(as.character(x$analysis), "separate_gwas") +}) + +test_that(".cbRunXqtlOnly passes a focal outcome through as an index", { + local_mocked_bindings( + .cbRun = function(label, args) { + list(result = list(focal = args$focal_outcome_idx), time = 0) + }, + .package = "pecotmr" + ) + bundle <- list( + outcomeNames = c("tA", "tB"), + Y = list(1, 2), + X = list(), + dict_YX = NULL + ) + run <- suppressMessages(pecotmr:::.cbRunXqtlOnly(bundle, "tB", list())) + # colocboost wants a position, not a name. + expect_equal(run$result$focal, 2L) + absent <- suppressMessages( + pecotmr:::.cbRunXqtlOnly(bundle, "nope", list()) + ) + expect_null(absent$result$focal) + none <- suppressMessages(pecotmr:::.cbRunXqtlOnly(bundle, NULL, list())) + expect_null(none$result$focal) +}) + +test_that(".cbAppendGwasPairs disambiguates a colliding study key", { + local_mocked_bindings( + .cbRequireSumStatsQc = function(...) invisible(NULL), + .cbGwasSumStatsBundle = function(gwasSumStats, cutoffs) { + list(dup = "GWAS") + }, + .package = "pecotmr" + ) + out <- pecotmr:::.cbAppendGwasPairs( + list(dup = "QTL", other = "X"), + "notNull", + qtlLdSketch = NULL + ) + # The QTL pair keeps its key; the GWAS pair is suffixed rather than + # overwriting it. + expect_equal(names(out), c("dup", "other", "dup.1")) + expect_equal(out[["dup"]], "QTL") + expect_equal(out[["dup.1"]], "GWAS") +}) diff --git a/tests/testthat/test_crossValidation.R b/tests/testthat/test_crossValidation.R index 8507598c..671dab2e 100644 --- a/tests/testthat/test_crossValidation.R +++ b/tests/testthat/test_crossValidation.R @@ -310,3 +310,38 @@ test_that("a NULL per-method weight matrix yields an all-NA prediction, not an e expect_true(all(is.na(r$prediction$empty_predicted))) expect_false(all(is.na(r$prediction$mock_predicted))) }) + + +test_that("sample names are synthesized when neither matrix carries rownames", { + # The CV split is keyed by sample name, so unnamed inputs still need a + # stable per-row identity rather than falling back to positions. + X <- matrix(1:6, 3L, 2L) + Y <- matrix(1:3, 3L, 1L) + out <- pecotmr:::.cvSetDimnames(X, Y) + expect_equal(rownames(out$X), c("sample_1", "sample_2", "sample_3")) + expect_equal(rownames(out$Y), rownames(out$X)) +}) + +test_that("numThreads = -1 asks BiocParallel for the worker count", { + # -1 means "all available"; anything else is capped at what is available. + expect_equal( + pecotmr:::.cvNumCores(-1), + BiocParallel::bpworkers(BiocParallel::MulticoreParam()) + ) + expect_equal(pecotmr:::.cvNumCores(1), 1) +}) + +test_that("a seed makes a CV call reproducible without leaking RNG state", { + # withr::local_seed, not set.seed: the caller's stream must be untouched + # after the call returns (Bioconductor asks packages not to set.seed). + f <- function() { + pecotmr:::.applySeed(42) + runif(1) + } + expect_equal(f(), f()) + set.seed(1) + before <- runif(1) + set.seed(1) + invisible(f()) + expect_equal(runif(1), before) +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index 27daa80b..33ec6f74 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -442,7 +442,7 @@ test_that(".ctwasRequireMatchingLdSketches: panel-size mismatch errors", { test_that(".ctwasBuildZSnp: produces a flat data.frame keyed by SNP/study", { ss <- .ctp_makeGwasSumstats(blockIds = "block1") - df <- pecotmr:::.ctwasBuildZSnp(ss) + df <- pecotmr:::.ctwasBuildZSnp(ss, vapply(1:6, .ctp_snpId, character(1))) expect_s3_class(df, "data.frame") expect_equal(nrow(df), 6L) expect_setequal( @@ -453,6 +453,96 @@ test_that(".ctwasBuildZSnp: produces a flat data.frame keyed by SNP/study", { expect_setequal(unique(df$study), "G1") }) +test_that(".ctwasBuildZSnp: negates z for a panel-flipped variant", { + # z arrives in the GWAS frame while R/variance/weights are in the panel's. + # An exact-string join dropped a swapped spelling silently -- present on + # both sides, so nothing reported it missing and the gene just lost an + # instrument. + ss <- .ctp_makeGwasSumstats(blockIds = "block1") + gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + panelIds <- gwasIds + panelIds[2] <- "chr1:200:A:G" # fixture spells this one G:A + plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) + flipped <- pecotmr:::.ctwasBuildZSnp(ss, panelIds) + i <- match("chr1:200:G:A", plain$id) + expect_equal(flipped$id[i], "chr1:200:A:G") + expect_equal(flipped$z[i], -plain$z[i]) + expect_equal(flipped$A1[i], plain$A2[i]) + expect_equal(flipped$A2[i], plain$A1[i]) + expect_equal(flipped$id[-i], plain$id[-i]) + expect_equal(flipped$z[-i], plain$z[-i]) +}) + +test_that(".ctwasBuildZSnp: leaves variants absent from the panel untouched", { + ss <- .ctp_makeGwasSumstats(blockIds = "block1") + gwasIds <- vapply(1:6, .ctp_snpId, character(1)) + plain <- pecotmr:::.ctwasBuildZSnp(ss, gwasIds) + none <- pecotmr:::.ctwasBuildZSnp(ss, "chr9:999:A:T") + expect_equal(none$id, plain$id) + expect_equal(none$z, plain$z) +}) + +test_that(".ctwasFilterVariants: a CS member the fine-mapping spells flipped still survives the cap", { + # The weights arrive in the panel frame, the fine-mapping auxiliaries in + # the fine-mapping result's. An exact-string join lost the credible-set + # member's must-keep protection, so the cap dropped the variant the + # fine-mapping was most confident about and kept the largest |w| instead. + vids <- c("chr1:100:G:A", "chr1:200:G:A", "chr1:300:G:A") + w <- c(0.1, 0.2, 0.9) + aux <- list( + pip = NULL, + csMembers = list("chr1:100:A:G"), # flipped spelling of vids[1] + csPurity = 0.9 + ) + out <- pecotmr:::.ctwasFilterVariants( + vids, + w, + finemapAux = aux, + twasWeightCutoff = 0, + csMinCor = 0.8, + minPipCutoff = 0, + maxNumVariants = 1 + ) + expect_equal(out$vids, "chr1:100:G:A") +}) + +test_that(".ctwasFilterVariants: PIPs spelled flipped still drive the cap", { + vids <- c("chr1:100:G:A", "chr1:200:G:A", "chr1:300:G:A") + w <- c(0.1, 0.2, 0.9) + aux <- list( + pip = c("chr1:100:A:G" = 0.95, "chr1:300:A:G" = 0.01), + csMembers = list(), + csPurity = numeric(0) + ) + out <- pecotmr:::.ctwasFilterVariants( + vids, + w, + finemapAux = aux, + twasWeightCutoff = 0, + csMinCor = 0, + minPipCutoff = 0, + maxNumVariants = 1 + ) + # PIP 0.95 wins over the larger |w| whose PIP is 0.01. + expect_equal(out$vids, "chr1:100:G:A") +}) + +test_that(".ctwasSnpInfoForGwasBlock: keeps rows the GWAS spells flipped", { + # Regression: `is_in()` on the id string retained none of these. + ss <- .ctp_makeGwasSumstats(blockIds = "block1") + flippedPanel <- data.frame( + chrom = rep(1L, 6), + id = sprintf("chr1:%d:A:G", 100L * (1:6)), + pos = 100L * (1:6), + alt = rep("A", 6), + ref = rep("G", 6), + stringsAsFactors = FALSE + ) + keep <- pecotmr:::.ctwasSnpInfoForGwasBlock(ss, flippedPanel) + expect_equal(nrow(keep), 6L) + expect_equal(keep$id, flippedPanel$id) +}) + test_that(".ctwasBuildSingleRegionInfo: pulls chrom + bp span from the GWAS block entry", { # Bounds come from the block's GWAS variants (the GwasSumStats entry), NOT # the LD sketch — many blocks can share one whole-chromosome LD payload. @@ -3093,3 +3183,551 @@ test_that("finemapCtwasRegions: an empty screened-region set returns a NULL fine expect_null(out$finemap_res) expect_null(out$susie_alpha_res) }) + +# ============================================================================= +# Bundled example payloads: portable LD tokens +# +# `LD_map$LD_file` is both something ctwas asserts exists on disk and the key +# pecotmr dispatches on into the cached LD panels. Serialising an absolute +# path made the bundled payloads carry the build machine's path, so +# finemapCtwasRegions() died on `all(file.exists(LD_matrix_files))` for every +# user. They now carry a "pecotmr://extdata/..." token resolved on the way in. +# ============================================================================= + +test_that("bundled cTWAS payloads carry a resolvable LD token", { + data(ctwasInputsExample) + data(ctwasEstExample) + data(ctwasFinemapExample) + + for (payload in list( + ctwasInputsExample, + ctwasEstExample, + ctwasFinemapExample + )) { + tokens <- as.character(payload$LD_map$LD_file) + expect_true(all(startsWith(tokens, "pecotmr://extdata/"))) + resolved <- vapply( + tokens, + pecotmr:::.resolveCtwasLdToken, + character(1), + USE.NAMES = FALSE + ) + expect_true(all(file.exists(resolved))) + expect_equal( + as.character(payload$LD_map$SNP_file), + tokens + ) + } +}) + +test_that("resolving the LD token keeps the loader cache keys in step", { + data(ctwasEstExample) + resolved <- pecotmr:::.ctwasResolveLdPaths(ctwasEstExample) + token <- resolved$LD_map$LD_file[[1]] + + # Rewriting LD_map without re-keying the closures would leave the loader + # unable to find its panel -- the failure this pairing exists to prevent. + expect_true(file.exists(token)) + expect_true(is.matrix(resolved$LD_loader_fun(token))) + expect_false(is.null(resolved$snpinfo_loader_fun(token))) +}) + +test_that("an ordinary LD path is left alone", { + expect_equal( + pecotmr:::.resolveCtwasLdToken("/some/real/path.pgen"), + "/some/real/path.pgen" + ) + noLdMap <- list(z_snp = NULL) + expect_equal(pecotmr:::.ctwasResolveLdPaths(noLdMap), noLdMap) + # Hand-built payloads reach the granular steps with an LD_map stub that is + # not a table at all; it has to survive untouched rather than error. + stub <- list(LD_map = "ld", LD_loader_fun = function() NULL) + expect_equal(pecotmr:::.ctwasResolveLdPaths(stub), stub) + expect_equal( + pecotmr:::.ctwasResolveLdPaths(list(LD_map = list(other = 1))), + list(LD_map = list(other = 1)) + ) +}) + +test_that("finemapCtwasRegions runs from the bundled est payload", { + skip_if_not_installed("ctwas") + data(ctwasEstExample) + # The step that the stale absolute paths broke. + screened <- suppressMessages( + screenCtwasRegions(ctwasEstExample, min_nonSNP_PIP = 0) + ) + out <- suppressMessages(finemapCtwasRegions(screened)) + expect_gt(nrow(out$finemap_res), 0L) +}) + + +# ============================================================================= +# ctwasPipeline shares the LD-sketch validator +# +# ctwasPipeline cannot use `.ldFromSketch()` itself: it needs the whole panel +# rather than a matched subset, and returns per-variant variance alongside R. +# It must still fail the same way when the LD reference is missing, rather +# than surfacing an S4 dispatch error from deep inside. +# ============================================================================= + +test_that("ctwas LD assembly reports a missing LD sketch like everything else", { + expect_error( + pecotmr:::.ctwasComputeFullPanelLd(NULL), + "carries no ldSketch" + ) + expect_error( + pecotmr:::.ctwasComputeFullPanelLd("not a panel"), + "must be a genotype panel" + ) +}) + +test_that("the shared validator gives ctwas and .ldFromSketch one message", { + shared <- tryCatch( + pecotmr:::.ldFromSketch(NULL, "chr1:1:A:G", label = "ctwasPipeline"), + error = conditionMessage + ) + own <- tryCatch( + pecotmr:::.ctwasComputeFullPanelLd(NULL), + error = conditionMessage + ) + expect_equal(own, shared) +}) + + +# =========================================================================== +# Degenerate inputs to the ctwas assembly helpers +# =========================================================================== + +test_that("gene coordinates are NULL when there are no weights", { + expect_null(pecotmr:::.ctwasGeneCoords(NULL)) + expect_null(pecotmr:::.ctwasGeneCoords(list())) +}) + +test_that("z harmonization is a no-op when either side is empty", { + # Both exits return the input untouched: an empty GWAS has nothing to + # relabel, and an empty panel has nothing to relabel it to. + empty <- tibble( + id = character(0), + chrom = integer(0), + pos = integer(0), + A1 = character(0), + A2 = character(0), + z = numeric(0), + study = character(0) + ) + expect_equal( + nrow(pecotmr:::.ctwasHarmonizeZToPanel(empty, "chr1:1:A:G")), + 0L + ) + one <- tibble( + id = "chr1:1:A:G", + chrom = 1L, + pos = 1L, + A1 = "G", + A2 = "A", + z = 1.5, + study = "S" + ) + expect_identical( + pecotmr:::.ctwasHarmonizeZToPanel(one, character(0)), + one + ) + # A panel that shares no variant leaves the ids alone. + expect_equal( + pecotmr:::.ctwasHarmonizeZToPanel(one, "chr9:9:C:T")$id, + "chr1:1:A:G" + ) +}) + +test_that("alpha renormalization refuses a row with no finite mass", { + # log(0) across a whole row leaves no maximum to subtract, so the + # renormalized alpha would be NaN rather than a distribution. + alpha <- matrix(c(0, 0, 0.5, 0.5), nrow = 2L, byrow = TRUE) + expect_null(pecotmr:::.ctwasRenormAlpha(alpha, 1:2)) + ok <- matrix(c(0.25, 0.75, 0.5, 0.5), nrow = 2L, byrow = TRUE) + out <- pecotmr:::.ctwasRenormAlpha(ok, 1:2) + expect_equal(unname(rowSums(out)), c(1, 1)) +}) + + +test_that("the SNP background row is omitted when no SNP rows were fitted", { + # ctwas tags its non-gene background with type == "SNP"; a run with none + # contributes no row rather than an empty one. + expect_null( + pecotmr:::.ctwasSnpRow("G", "susie", "", NULL, NULL, NULL) + ) +}) + +test_that("subsetting to SNP rows answers NULL when there are none", { + expect_null(pecotmr:::.ctwasSubsetSnp(NULL)) + geneOnly <- data.frame( + id = "a", + type = "gene", + stringsAsFactors = FALSE + ) + expect_null(pecotmr:::.ctwasSubsetSnp(geneOnly)) + mixed <- data.frame( + id = c("a", "b"), + type = c("SNP", "gene"), + stringsAsFactors = FALSE + ) + expect_equal(nrow(pecotmr:::.ctwasSubsetSnp(mixed)), 1L) +}) + + +# =========================================================================== +# Assembly shortcuts and block placement +# =========================================================================== + +test_that("a precomputed z_gene is used rather than recomputed", { + # compute_gene_z is the expensive step; supplying it must short-circuit. + expect_equal( + pecotmr:::.ctwasEnsureZGene(list(z_gene = "PRECOMPUTED"), 1L), + "PRECOMPUTED" + ) +}) + +test_that("boundary genes are NULL for a single-region run", { + # Boundary adjustment only means something across two or more regions. + expect_null(pecotmr:::.ctwasBoundaryGenes( + list(region_info = data.frame(a = 1)), + 1L, + list() + )) +}) + +test_that("relabelling ids is a no-op on an empty set and flips when matched", { + expect_equal( + pecotmr:::.ctwasRelabelIds(character(0), "chr1:1:A:G"), + character(0) + ) + # A swapped spelling is the same variant, relabelled to the panel frame. + expect_equal( + pecotmr:::.ctwasRelabelIds("chr1:1:G:A", "chr1:1:A:G"), + "chr1:1:A:G" + ) +}) + +test_that("re-keying LD loaders is a no-op when no panels are cached", { + payload <- list(a = 1) + expect_identical( + pecotmr:::.ctwasRekeyLdLoaders(payload, list(x = "y")), + payload + ) +}) + +test_that("a variant is placed in the block whose half-open window holds it", { + # [start, end): an unplaceable or out-of-range anchor is NA rather than + # being snapped to the nearest block. + f <- pecotmr:::.ctwasBlockIdForVariant + expect_equal(f(1L, 50L, "1", "1", 1L, 100L, "B1"), "B1") + expect_true(is.na(f(1L, 500L, "1", "1", 1L, 100L, "B1"))) + expect_true(is.na(f(1L, NA_integer_, "1", "1", 1L, 100L, "B1"))) + # The window excludes its end. + expect_true(is.na(f(1L, 100L, "1", "1", 1L, 100L, "B1"))) +}) + + +# =========================================================================== +# Row coordinates, trait positions and the loader panel cache +# =========================================================================== + +test_that("row coordinates prefer the gene cache, then the variant id", { + # Genes are keyed by name and have no parseable coordinates; variants + # carry theirs in the id. An id that is neither is NULL rather than a + # fabricated position. + f <- pecotmr:::.ctwasRowCoord + cached <- f(1L, "G1", list(G1 = list(chrom = "chr9", start = 5L, end = 9L))) + expect_equal(cached$chrom, "chr9") + parsed <- f(1L, "chr1:100:A:G", NULL) + expect_equal(parsed$chrom, "chr1") + expect_equal(parsed$start, 100L) + # A single-base variant spans one position. + expect_equal(parsed$end, 100L) + expect_null(f(1L, "rsNOTPARSEABLE", NULL)) +}) + +test_that("trait positions are NULL when the weights do not carry them", { + data(twasWeightsExample) + expect_false( + is_in("traitPos", pecotmr:::.tupleColumnNames(twasWeightsExample)) + ) + expect_null(pecotmr:::.ctwasTraitPosAt(twasWeightsExample, 1L)) +}) + +test_that("the panel cache is NULL for loaders this package did not build", { + # Re-keying only makes sense over our own closure; a foreign or + # non-function loader is left alone rather than reached into. + expect_null(pecotmr:::.ctwasCachedPanels(list(LD_loader_fun = "nope"))) + expect_null( + pecotmr:::.ctwasCachedPanels(list(LD_loader_fun = function(x) x)) + ) +}) + + +# =========================================================================== +# Input validation +# =========================================================================== + +test_that("block ids must be present, non-empty and unique", { + # blockId becomes the region id, so a missing or empty one leaves an + # element unkeyable and a repeated one would have two elements silently + # overwrite each other. + gs <- .ctp_makeGwasSumstats(blockIds = c("block1", "block2")) + expect_silent(pecotmr:::.ctwasValidateGwasEntries(gs)) + + missing <- gs + S4Vectors::mcols(missing)$blockId <- c("b", NA_character_) + expect_error( + pecotmr:::.ctwasValidateGwasEntries(missing), + "empty or missing `blockId`" + ) + + blank <- gs + S4Vectors::mcols(blank)$blockId <- c("", "b2") + expect_error( + pecotmr:::.ctwasValidateGwasEntries(blank), + "empty or missing `blockId`" + ) + + dup <- gs + S4Vectors::mcols(dup)$blockId <- c("dup", "dup") + expect_error( + pecotmr:::.ctwasValidateGwasEntries(dup), + "block ids must be unique; repeated: dup" + ) +}) + +test_that("each weight entry must be a TwasWeights or QtlFineMappingResult", { + # The per-gene weight source is one of those two; anything else would + # fail later inside the assembly with a far less specific message. + expect_error( + pecotmr:::.ctwasValidateWeightEntries(list(r1 = "not a TwasWeights")), + "twasWeights\\[\\['r1'\\]\\] must be a TwasWeights or QtlFineMappingResult" + ) +}) + +# --------------------------------------------------------------------------- +# Input guards and coordinate fallbacks: each rejects a shape the pipeline +# cannot proceed on, or substitutes a placeholder for an unplaced feature. +# --------------------------------------------------------------------------- + +test_that(".ctwasValidateGwasList requires a blockId column", { + skip_if_not_installed("ctwas") + gss <- .ctp_makeGwasSumstats() + # A GwasSumStats built by a current constructor always carries blockId; + # dropping it stands in for an object deserialized from an older one. + S4Vectors::mcols(gss)$blockId <- NULL + expect_false(is_in("blockId", colnames(gss))) + expect_error( + pecotmr:::.ctwasValidateGwasList(gss), + "has no `blockId` column" + ) +}) + +test_that(".ctwasResolveAndValidateWeights requires a weight source", { + expect_error( + pecotmr:::.ctwasResolveAndValidateWeights(NULL, NULL), + "`twasWeights` is required" + ) + expect_error( + pecotmr:::.ctwasResolveAndValidateWeights(), + "`twasWeights` is required" + ) +}) + +test_that(".ctwasPrefitRegionFilter errors when nothing survives", { + regionData <- list( + r1 = list(gid = character(0), sid = "s1"), + r2 = list(gid = character(0), sid = character(0)) + ) + # Default minGene = 1 drops both regions: neither carries a gene. + expect_error( + pecotmr:::.ctwasPrefitRegionFilter(regionData, list()), + "No regions selected!" + ) + kept <- pecotmr:::.ctwasPrefitRegionFilter( + list(r1 = list(gid = "g1", sid = c("s1", "s2"))), + list() + ) + expect_equal(names(kept), "r1") +}) + +test_that(".ctwasBlockGrFromIds places unparseable ids on chrUn", { + # asGranges() warns on the unparseable id before erroring; the fallback + # catches the error, and the warning is incidental to what is tested. + gr <- suppressWarnings( + pecotmr:::.ctwasBlockGrFromIds(c("chr1_100_200", "not-a-region")) + ) + expect_equal( + as.character(GenomicRanges::seqnames(gr)), + c("chr1", "chrUn") + ) + # start = 1, end = 0 is a deliberately EMPTY range, so an unplaced block + # overlaps nothing rather than silently matching everything. + expect_equal(GenomicRanges::start(gr), c(100L, 1L)) + expect_equal(GenomicRanges::end(gr), c(200L, 0L)) + expect_equal(GenomicRanges::width(gr)[[2L]], 0L) +}) + +test_that(".ctwasCoordField falls back for an unplaced feature", { + expect_equal(pecotmr:::.ctwasCoordField(NULL, "chrom", TRUE), "chrUnplaced") + expect_equal(pecotmr:::.ctwasCoordField2(NULL, "start", TRUE), 1L) + co <- list(chrom = "chr7", start = 42L) + expect_equal(pecotmr:::.ctwasCoordField(co, "chrom", TRUE), "chr7") + expect_equal(pecotmr:::.ctwasCoordField2(co, "start", TRUE), 42L) +}) + +test_that(".ctwasBuildSingleRegionInfo reports an empty block accurately", { + emptyGr <- GenomicRanges::GRanges() + S4Vectors::mcols(emptyGr)$variant_id <- character(0) + S4Vectors::mcols(emptyGr)$Z <- numeric(0) + S4Vectors::mcols(emptyGr)$N <- integer(0) + gss <- GwasSumStats( + study = "G1", + entry = list(emptyGr), + genome = "hg19", + blockId = "b1" + ) + # Emptiness is checked before the chromosome count -- otherwise a block + # with no variants is reported as spanning "multiple chromosomes ()". + expect_error( + pecotmr:::.ctwasBuildSingleRegionInfo("b1", gss), + "has no variants to define region bounds" + ) +}) + +# --------------------------------------------------------------------------- +# Per-gene weight assembly: each skip below returns NULL so the gene drops out +# of the run, rather than contributing a mis-sliced weight vector. +# --------------------------------------------------------------------------- + +.ctp_noLdGwas <- function() { + mkGr <- function(chr, pos) { + g <- GenomicRanges::GRanges(chr, IRanges::IRanges(pos, width = 1)) + S4Vectors::mcols(g)$variant_id <- str_c(chr, ":", pos, ":A:G") + S4Vectors::mcols(g)$Z <- rep(1, length(pos)) + S4Vectors::mcols(g)$N <- rep(100L, length(pos)) + g + } + GwasSumStats( + study = c("G1", "G1"), + entry = list(mkGr("chr1", c(100L, 200L)), mkGr("chr1", c(300L, 400L))), + genome = "hg19", + blockId = c("b1", "b2"), + qcInfo = list(step1 = "ok") + ) +} + +test_that(".ctwasFirstPass requires an LD reference on every region", { + byBlock <- pecotmr:::.ctwasGwasByBlock(.ctp_noLdGwas()) + expect_null(getLdSketch(byBlock[[1L]])) + expect_error( + pecotmr:::.ctwasFirstPass("b1", byBlock, list(b1 = NULL)), + "region 'b1' carries no ldSketch" + ) +}) + +test_that("ctwasPipeline aborts when no genes could be modeled", { + local_mocked_bindings( + .ctwasRequireNamedLists = function(...) invisible(NULL), + .ctwasResolveMethods = function(...) "susie", + .ctwasGwasStudy = function(...) "G1", + .ctwasRunMethod = function(...) list(), + .package = "pecotmr" + ) + expect_error( + ctwasPipeline(gwasSumStats = .ctp_noLdGwas(), twasWeights = list()), + "no genes were modeled" + ) +}) + +test_that(".ctwasAlignGeneWeights returns NULL when the row has no variants", { + row <- twasWeightsRow(variantIds = character(0), weights = numeric(0)) + expect_null(pecotmr:::.ctwasAlignGeneWeights(row, NULL, NULL)) +}) + +test_that(".ctwasTraitPosAt is bounded by the traitPos column length", { + row <- fineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + susieFit = list(pip = c(0.8, 0.2)), + topLoci = data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0.8, 0.2), + stringsAsFactors = FALSE + ) + ) + res <- GwasFineMappingResult( + study = "G1", + method = "susie", + entry = list(row), + traitPos = GenomicRanges::GRanges("chr1", IRanges::IRanges(500, 900)) + ) + expect_s4_class(pecotmr:::.ctwasTraitPosAt(res, 1L), "GRanges") + # One row, so row 2 has no anchor to report. + expect_null(pecotmr:::.ctwasTraitPosAt(res, 2L)) +}) + +test_that(".ctwasRenormalizeSusieWeights skips fits it cannot slice", { + alpha <- matrix(c(0.5, 0.5, 0.3, 0.7), nrow = 2L, byrow = TRUE) + mu <- matrix(1, nrow = 2L, ncol = 2L) + good <- list(alpha = alpha, mu = mu, X_column_scale_factors = c(1, 1)) + origVids <- c("v1", "v2") + origW <- c(0.5, 0.5) + keptIdx <- c(1L, 2L) + harmonizedW <- c(0.5, 0.5) + run <- function(fits) { + pecotmr:::.ctwasRenormalizeSusieWeights( + fits, origVids, origW, keptIdx, harmonizedW + ) + } + # Any missing susie field: nothing to renormalize from. + expect_null(run(list(mu = mu, X_column_scale_factors = c(1, 1)))) + expect_null(run(list(alpha = alpha, X_column_scale_factors = c(1, 1)))) + expect_null(run(list(alpha = alpha, mu = mu))) + # susieInf / susieAsh carry an infinitesimal term that alpha and mu alone + # cannot reproduce, so those fits take the plain subset path instead. + expect_null(run(c(good, list(theta = 1)))) + expect_null(run(c(good, list(omega_weights = 1)))) + # Fit-vs-entry dimension mismatch (e.g. a null_weight fit's extra column). + expect_null(run(list( + alpha = matrix(0.25, nrow = 2L, ncol = 3L), + mu = matrix(1, nrow = 2L, ncol = 3L), + X_column_scale_factors = c(1, 1, 1) + ))) + # An all-zero alpha has no finite row maximum in log space. + expect_null(run(list( + alpha = matrix(0, nrow = 2L, ncol = 2L), + mu = mu, + X_column_scale_factors = c(1, 1) + ))) + expect_equal(run(good), c(0.8, 1.2)) +}) + +test_that(".ctwasResolveAndValidateWeights requires region_id names", { + local_mocked_bindings( + .ctwasResolveWeightBuckets = function(twasWeights, gwasSumStats) { + list("a", "b") + }, + .package = "pecotmr" + ) + expect_error( + pecotmr:::.ctwasResolveAndValidateWeights(list(x = 1), NULL), + "must resolve to a named list keyed by region_id" + ) +}) + +test_that(".ctwasResolveAndValidateWeights rejects a blank region name", { + local_mocked_bindings( + .ctwasResolveWeightBuckets = function(twasWeights, gwasSumStats) { + stats::setNames(list("a", "b"), c("r1", "")) + }, + .package = "pecotmr" + ) + # A partially-named list is as unusable as an unnamed one: the blank key + # cannot address a region. + expect_error( + pecotmr:::.ctwasResolveAndValidateWeights(list(x = 1), NULL), + "must resolve to a named list keyed by region_id" + ) +}) diff --git a/tests/testthat/test_data/sldscUpstreamZ.rds b/tests/testthat/test_data/sldscUpstreamZ.rds new file mode 100644 index 00000000..4d003331 Binary files /dev/null and b/tests/testthat/test_data/sldscUpstreamZ.rds differ diff --git a/tests/testthat/test_exampleData.R b/tests/testthat/test_exampleData.R index 3e7551a6..d18518aa 100644 --- a/tests/testthat/test_exampleData.R +++ b/tests/testthat/test_exampleData.R @@ -113,3 +113,73 @@ test_that("S4 example collections are non-empty and self-consistent", { expect_equal(length(colnames(obj)), ncol(obj)) } }) + + +# ============================================================================= +# The LD references have to be big enough to actually estimate with. +# +# Their predecessors were 20 variants in 2 blocks: fine for demonstrating the +# accessors, useless for estimateH2(), which returned a boundary value near +# zero for every method. A rebuild that shrinks them back would break the +# heritability documentation without breaking any accessor test, so assert +# the properties the estimators depend on. +# ============================================================================= + +test_that("the bundled LD references describe one shared variant set", { + data(ldEigenExample) + data(ldScoreExample) + expect_equal(length(ldEigenExample), length(ldScoreExample)) + expect_equal(names(ldEigenExample), names(ldScoreExample)) + expect_equal(getGenome(ldEigenExample), getGenome(ldScoreExample)) + # Two routes to the same quantity; disagreement means one has drifted. + expect_equal( + as.vector(getLdScores(ldScoreExample)[, 1]), + as.vector(computeLdScores(ldEigenExample)[, 1]) + ) +}) + +test_that("the bundled LD references support a block jackknife", { + data(ldEigenExample) + data(ldScoreExample) + # estimateH2 requires at least two blocks and wants many more. + expect_gte(length(getEigenList(ldEigenExample)), 10L) + expect_gte(length(getLdMatrixList(ldScoreExample)), 10L) + expect_gt(length(ldEigenExample), 500L) +}) + +test_that("every estimateH2 method runs on the bundled LD references", { + data(ldEigenExample) + data(ldScoreExample) + gr <- as(ldScoreExample, "GRanges") + set.seed(1) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = names(ldScoreExample), + A1 = S4Vectors::mcols(ldScoreExample)$A1, + A2 = S4Vectors::mcols(ldScoreExample)$A2, + Z = rnorm(length(ldScoreExample)), + N = 100000L + ) + panel <- readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) + ss <- GwasSumStats( + study = "trait1", + entry = list(gr), + genome = getGenome(ldScoreExample), + ldSketch = panel + ) + for (method in c("sldsc", "gldsc")) { + res <- estimateH2(ss, ldScoreExample, method = method) + expect_s4_class(res, "H2Estimate") + expect_true(is.finite(getH2(res)), info = method) + expect_true(is.finite(getH2Se(res)), info = method) + expect_gt(getH2Se(res), 0) + } + for (method in c("lder", "hdl")) { + res <- suppressWarnings( + estimateH2(ss, ldEigenExample, method = method) + ) + expect_s4_class(res, "H2Estimate") + expect_true(is.finite(getH2(res)), info = method) + } +}) diff --git a/tests/testthat/test_fineMappingRow.R b/tests/testthat/test_fineMappingRow.R index 173abfdc..c3bbebf0 100644 --- a/tests/testthat/test_fineMappingRow.R +++ b/tests/testthat/test_fineMappingRow.R @@ -1455,3 +1455,210 @@ test_that("a fit with no stored sets falls back to the per-variant column", { expect_equal(s$n_variants, 2L) expect_equal(s$cs, "susie_1") }) + + +# =========================================================================== +# Purity filtering, coverage defaults and column projection +# =========================================================================== + +test_that("purity filtering keeps everything when there is nothing to judge", { + # No purity columns, or purity columns with no matching cs column: the + # entry cannot be assessed, so nothing is dropped rather than everything. + tl <- tibble(variant_id = c("a", "b"), pip = c(0.1, 0.9)) + expect_equal(pecotmr:::.fmePurityKeep(tl, 0.8), c(TRUE, TRUE)) + tl2 <- tibble( + variant_id = c("a", "b"), + cs_0.95_purity = c(0.9, 0.2) + ) + expect_equal(pecotmr:::.fmePurityKeep(tl2, 0.8), c(TRUE, TRUE)) +}) + +test_that("purity filtering drops only in-CS variants below the threshold", { + # `susie_0` means "in no credible set", so that row survives regardless + # of the purity recorded beside it. + tl <- tibble( + variant_id = c("a", "b"), + cs_0.95 = c("susie_1", "susie_0"), + cs_0.95_purity = c(0.2, 0.9) + ) + expect_equal(pecotmr:::.fmePurityKeep(tl, 0.8), c(FALSE, TRUE)) +}) + +test_that("an unusable coverage falls back to 0.95", { + expect_equal(pecotmr:::.adjustPipsCoverage(NULL), 0.95) +}) + +test_that("the credible-set prefix defaults to cs with no method column", { + tl <- tibble(variant_id = c("a", "b"), pip = c(0.1, 0.9)) + expect_equal(pecotmr:::.adjustPipsMethodLabel(tl), "cs") +}) + +test_that("projecting an absent column yields typed NAs of the right length", { + # One NA per row, of the requested type, so the column binds against the + # rest of the table instead of collapsing it. + tl <- tibble(variant_id = c("a", "b"), pip = c(0.1, 0.9)) + expect_equal( + pecotmr:::.tlCol(tl, "nope", "character"), + rep(NA_character_, 2L) + ) + expect_equal(pecotmr:::.tlCol(tl, "nope", "numeric"), rep(NA_real_, 2L)) + expect_equal(pecotmr:::.tlCol(tl, "nope", "integer"), rep(NA_integer_, 2L)) + expect_equal(pecotmr:::.tlCol(tl, "pip", "numeric"), c(0.1, 0.9)) +}) + + +# =========================================================================== +# Credible-set summary assembly and PIP adjustment +# =========================================================================== + +test_that("an absent or empty topLoci summarises to the empty CS table", { + expect_equal(nrow(pecotmr:::.csSummaryFit(NULL, list(), 0.95)), 0L) + expect_equal( + nrow(pecotmr:::.csSummaryFit(tibble(a = integer(0)), list(), 0.95)), + 0L + ) +}) + +test_that("credible sets are resolved from the secondary store by coverage", { + # A trimmed fit keeps non-primary coverages in sets_secondary, keyed + # cs__; asking for a coverage it does not hold is NULL, not the + # primary sets, which would silently answer the wrong question. + sec <- list(cs_70_x = list(sets = list(cs = list(L1 = 1:2)))) + fit <- list(sets = list(), sets_secondary = sec) + expect_equal( + pecotmr:::.csSetsForCoverage(fit, 0.70)$cs$L1, + 1:2 + ) + expect_null(pecotmr:::.csSetsForCoverage(fit, 0.95)) +}) + +test_that("an untrimmed fit with no recorded coverage uses its primary sets", { + # No requested_coverage and no secondary store: the primary sets are the + # only ones there are, so they answer for any coverage. + fit <- list(sets = list(cs = list(L1 = 1:2))) + expect_equal(pecotmr:::.csSetsForCoverage(fit, 0.95)$cs$L1, 1:2) +}) + +test_that("mean conditional effect is NA when the column is absent", { + expect_true(is.na(pecotmr:::.csMeanEffect(tibble(a = 1)))) + expect_equal( + pecotmr:::.csMeanEffect(tibble(conditional_effect = c(1, 3))), + 2 + ) +}) + +test_that("rebuilding an empty topLoci returns it unchanged", { + tl <- tibble(variant_id = character(0)) + expect_equal( + nrow(pecotmr:::.adjustPipsRebuildTopLoci(tl, list(), character(0))), + 0L + ) +}) + +test_that("posterior columns are left in place when the fit has no alpha", { + # Without alpha there is nothing to recompute from, so the existing + # values stay rather than being overwritten with NA. + tl <- tibble(variant_id = "a") + expect_equal(pecotmr:::.adjustPipsPosterior(tl, list())$variant_id, "a") +}) + +# --------------------------------------------------------------------------- +# adjustPips index resolution and the CS-label fallbacks: each decides how a +# fit slot lines up with the entry's variants, or what to call a set when the +# table does not say. +# --------------------------------------------------------------------------- + +test_that(".csMethodTag falls back to the fit class when no label survives", { + fit <- structure(list(), class = "susieAsh") + expect_equal(pecotmr:::.csMethodTag(NULL, fit, "cs_95"), "susie_ash") + # "_0" means "not in a credible set", so it is filtered out and cannot + # supply the tag either. + onlyNull <- data.frame( + variant_id = "v1", + cs_95 = "L1_0", + stringsAsFactors = FALSE + ) + expect_equal(pecotmr:::.csMethodTag(onlyNull, fit, "cs_95"), "susie_ash") + labelled <- data.frame( + variant_id = "v1", + cs_95 = "susie_1", + stringsAsFactors = FALSE + ) + expect_equal(pecotmr:::.csMethodTag(labelled, fit, "cs_95"), "susie") +}) + +test_that(".csSummaryRow returns NULL when the set has no rows in the table", { + ctx <- list( + tl = tibble::tibble(variant_id = c("v1", "v2"), pip = c(0.5, 0.5)) + ) + expect_null(pecotmr:::.csSummaryRow(list(ids = "zzz", eff = 1L), ctx)) +}) + +test_that(".adjustPipsIdxFor accepts the null-weight extra column", { + p <- list(nVariants = 3L, keepIdx = c(1L, 2L, 3L), cols = c(1L, 2L, 3L, 4L)) + expect_equal(pecotmr:::.adjustPipsIdxFor(3L, p, "alpha"), c(1L, 2L, 3L)) + # A null_weight fit carries one column MORE than the entry's variants. + expect_equal( + pecotmr:::.adjustPipsIdxFor(4L, p, "alpha"), + c(1L, 2L, 3L, 4L) + ) + expect_error( + pecotmr:::.adjustPipsIdxFor(9L, p, "alpha"), + "fit slot `alpha` spans 9 variants but the entry has 3" + ) +}) + +test_that(".adjustPipsCols treats a dimensionless slot as a vector", { + p <- list(nVariants = 3L, keepIdx = c(1L, 3L), cols = c(1L, 2L, 3L)) + expect_equal(pecotmr:::.adjustPipsCols(c(10, 20, 30), p, "pip"), c(10, 30)) + expect_null(pecotmr:::.adjustPipsCols(NULL, p, "pip")) +}) + +test_that(".adjustPipsRebuildSecondary passes through an entry with no sets", { + entry <- list(a = 1) + expect_identical( + pecotmr:::.adjustPipsRebuildSecondary(entry, NULL, NULL), + entry + ) +}) + +test_that(".adjustPipsMethodLabel defaults to 'cs'", { + expect_equal(pecotmr:::.adjustPipsMethodLabel(data.frame(x = 1)), "cs") + # A method column of all NA names nothing either. + expect_equal( + pecotmr:::.adjustPipsMethodLabel( + data.frame(method = NA_character_, stringsAsFactors = FALSE) + ), + "cs" + ) + expect_equal( + pecotmr:::.adjustPipsMethodLabel( + data.frame(method = "susie", stringsAsFactors = FALSE) + ), + "susie" + ) +}) + +test_that("show(FineMappingRow) reports zero sets for an empty row", { + empty <- fineMappingRow( + variantIds = character(0), + susieFit = list(pip = numeric(0)), + topLoci = data.frame( + variant_id = character(0), + pip = numeric(0), + stringsAsFactors = FALSE + ) + ) + expect_output(show(empty), "0 variants, 0 credible sets") + withCs <- fineMappingRow( + variantIds = c("chr1:1:A:G", "chr1:2:C:T"), + susieFit = list(pip = c(0.9, 0.1)), + topLoci = data.frame( + variant_id = c("chr1:1:A:G", "chr1:2:C:T"), + pip = c(0.9, 0.1), + cs_95 = c("L1_1", "L1_0"), + stringsAsFactors = FALSE + ) + ) + expect_output(show(withCs), "2 variants, 1 credible sets") +}) diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 09cbe6aa..d6296239 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -2837,7 +2837,8 @@ test_that("mvsusieWeights returns coefficients from provided fit", { expect_equal(result, fake_coef[-1, ]) }) -.fw_makeFsusieFit <- function(seed = 1, n = 150L, p = 24L, J = 16L) { +.fw_makeFsusieFit <- function(seed = 1, n = 150L, p = 24L, J = 16L, + prior = "mixture_normal_per_scale") { set.seed(seed) X <- matrix( rnorm(n * p), @@ -2860,6 +2861,7 @@ test_that("mvsusieWeights returns coefficients from provided fit", { Y = Y, pos = seq_len(J), L = 5, + prior = prior, post_processing = "none", verbose = FALSE )) @@ -3461,3 +3463,853 @@ test_that("getSusieResult returns NULL when the trimmed susie fit is empty", { ) expect_null(getSusieResult(conData)) }) + + +# =========================================================================== +# Weight extraction and variant parsing guards +# =========================================================================== + +test_that("susieRss weight extraction rejects a fit that does not match R", { + # A pip vector of a different length than R means the fit and the LD + # describe different variant sets; the weights would be silently + # mis-assigned rather than wrong-looking. + expect_error( + pecotmr:::.susieRssExtractWeights( + fit = list(pip = c(0.1, 0.2)), + z = c(1, 2, 3), + R = diag(3), + n = 100, + requiredFields = c("alpha", "mu") + ), + "Dimension mismatch: susieRss fit has 2 variants but R has 3 rows" + ) +}) + +test_that("susieRss weights are zero when the fit lacks the coefficient fields", { + # Without alpha/mu there is nothing to form coefficients from, so the + # contribution is zero rather than an error or a partial answer. + w <- pecotmr:::.susieRssExtractWeights( + fit = list(pip = c(0.1, 0.2, 0.3)), + z = c(1, 2, 3), + R = diag(3), + n = 100, + requiredFields = c("alpha", "mu", "X_column_scale_factors") + ) + expect_equal(w, c(0, 0, 0)) +}) + +test_that("susieRss weights carry the fit when asked to retain it", { + w <- pecotmr:::.susieRssExtractWeights( + fit = list(pip = c(0.1, 0.2, 0.3)), + z = c(1, 2, 3), + R = diag(3), + n = 100, + requiredFields = "absentField", + retainFit = TRUE + ) + expect_false(is.null(attr(w, "fit"))) + expect_equal(attr(w, "fit")$pip, c(0.1, 0.2, 0.3)) +}) + +test_that("buildTopLoci rejects variant ids it cannot place", { + # Coordinates are required to build the ranges; an unparseable id is an + # error rather than an NA row that looks like a real locus. + expect_error( + pecotmr:::.btlParseVariants(c("rsX", "rsY")), + "buildTopLoci: parseVariantId produced invalid coordinates" + ) + # ...and well-formed ids parse to their chrom/pos. + ok <- pecotmr:::.btlParseVariants(c("chr1:100:A:G", "chr1:200:C:T")) + expect_equal(ok$chrom, c("1", "1")) + expect_equal(ok$pos, c(100L, 200L)) +}) + + +# =========================================================================== +# Empty-input paths in the credible-set merge chain +# =========================================================================== + +test_that("merging overlapping sets with nothing to merge yields nothing", { + expect_equal( + pecotmr:::.mergeAndUpdateOverlapSets(list(), list()), + list() + ) + expect_null(pecotmr:::.combineTopLoci(list())) +}) + +test_that("correlation extraction reports NA when every value is self-correlation", { + # A single-variant set has only the diagonal, so there is no pairwise + # correlation to summarise -- reported as NA rather than 1. + both <- pecotmr:::.extractCorrelations(c(1, 1, 1)) + expect_true(is.na(both$max_corr)) + expect_true(is.na(both$min_corr)) + # Perfect correlations are excluded, magnitudes are used. + mixed <- pecotmr:::.extractCorrelations(c(1, 0.5, -0.9)) + expect_equal(mixed$max_corr, 0.9) + expect_equal(mixed$min_corr, 0.5) +}) + +test_that("getSusieResult returns NULL when there is no fine-mapping entry", { + expect_null(getSusieResult(list(finemappingEntry = NULL))) + expect_null(getSusieResult(list(finemappingEntry = 42))) +}) + + +# =========================================================================== +# Small credible-set helpers +# =========================================================================== + +test_that("purity lookup answers 0 for a missing or out-of-range set", { + # 0 rather than NA: these feed a comparison against minAbsCorr, and NA + # would make an unmeasurable set silently pass the filter. + expect_equal(pecotmr:::.csPurityAt(1L, c(0.5)), 0.5) + expect_equal(pecotmr:::.csPurityAt(2L, c(0.5, NA)), 0) + expect_equal(pecotmr:::.csPurityAt(9L, c(0.5)), 0) + expect_equal(pecotmr:::.csPurityAt(0L, c(0.5)), 0) +}) + +test_that("a cs label parses to its trailing index", { + expect_equal(pecotmr:::.cs95ToIndex("susie_3"), 3L) + # 0 marks "in no credible set", which is what an empty or NA label means. + expect_equal(pecotmr:::.cs95ToIndex(NA_character_), 0L) + expect_equal(pecotmr:::.cs95ToIndex(""), 0L) +}) + +test_that("the alpha row helper returns a plain numeric row", { + am <- matrix(1:6, 2L, 3L) + expect_equal(pecotmr:::.amRow(2L, am), c(2, 4, 6)) + expect_type(pecotmr:::.amRow(1L, am), "double") + expect_equal(length(pecotmr:::.fsusieAlphaList(am)), 2L) +}) + +test_that("between-CS correlation refuses an ldSource it cannot read LD from", { + # The correlation is derived from the source's LD and never stored on the + # fit, so an object that carries none cannot be silently accepted. + expect_error( + pecotmr:::.rowCsCorrelation(list(), 42), + "requires a QtlDataset, QtlSumStats, or GwasSumStats" + ) +}) + + +# =========================================================================== +# Coverage-indexed lookups and the buildTopLoci column builders +# =========================================================================== + +test_that("a coverage level the tables do not carry yields no credible sets", { + # Asking for 50% when only 95% was computed is not an error: the variant + # simply belongs to no set at that level. + tbl <- list(list(sets = list(cs = list(L1 = 1:2)))) + expect_equal( + pecotmr:::.fmCsIdxAtCoverage(0.5, c(0.95), tbl, nV = 3L), + integer(3) + ) + # ...and the effect-index mapping passes its input through unchanged. + expect_equal( + pecotmr:::.fmEffectIdxAtCoverage(0.5, c(7L, 8L), c(0.95), tbl), + c(7L, 8L) + ) +}) + +test_that("effect indices come from the L-names, falling back to position", { + # susie names its sets L; anything else is positional so the mapping + # never silently collapses two effects onto one index. + expect_equal(pecotmr:::.fmEffectIndices(list(1, 2)), 1:2) + expect_equal( + pecotmr:::.fmEffectIndices(set_names(list(1, 2), c("L3", "L5"))), + c(3L, 5L) + ) + # A name that is not L falls back to its own position, not to NA. + expect_equal( + pecotmr:::.fmEffectIndices(set_names(list(1, 2), c("L3", "junk"))), + c(3L, 2L) + ) +}) + +test_that("coverage levels are NA when the tables carry no attribute", { + expect_equal(pecotmr:::.btlCoverage(list(1, 2)), c(NA_real_, NA_real_)) + ct <- list(1, 2) + attr(ct, "coverage") <- c(0.95, 0.5) + expect_equal(pecotmr:::.btlCoverage(ct), c(0.95, 0.5)) +}) + +test_that("the N column falls back to the fit N and recycles a scalar", { + # Numeric throughout, so a fractional effective N is not truncated. + expect_equal(pecotmr:::.btlNColumn(NULL, 500L, 3L), rep(500L, 3L)) + expect_equal(pecotmr:::.btlNColumn(250, 500L, 3L), rep(250, 3L)) + expect_equal(pecotmr:::.btlNColumn(c(1, 2, 3), 500L, 3L), c(1, 2, 3)) + expect_type(pecotmr:::.btlNColumn(250.5, 500L, 2L), "double") +}) + + +# =========================================================================== +# buildTopLoci per-condition blocks +# =========================================================================== + +test_that("conditional effects are NA when the fit carries no coefficients", { + # susie without a coef matrix and no mvsusie fallback: one NA per variant + # rather than a shorter vector that would misalign the column. + out <- pecotmr:::.btlCondEffect(list(), "susie", 1L, 3L) + expect_length(out, 3L) + expect_true(all(is.na(out))) +}) + +test_that("conditional lfsr passes through when no coverage level matches", { + clf <- array(0.1, dim = c(2L, 3L, 1L)) + out <- pecotmr:::.btlCondLfsr( + list(lfsr = clf), + conditionIdx = 1L, + coverageValues = c(0.95), + covSorted = c(0.5), + csTables = list(list(sets = list(cs = list(L1 = 1:2)))), + nV = 3L + ) + expect_length(out, 3L) + expect_true(all(is.na(out))) +}) + +test_that("an empty credible-set spec still yields a correctly sized block", { + # tibble(.rows = nV): zero columns but the right number of rows, so it + # binds against the other blocks instead of collapsing the frame. + out <- pecotmr:::.btlCsBlock( + "susie", + list( + csEffectByCov = list(), + csColNames = character(0), + csPurityByCov = list() + ), + nV = 4L + ) + expect_equal(nrow(out), 4L) + expect_equal(ncol(out), 0L) +}) + + +# =========================================================================== +# computeCsCorrelation guards and the empty top_loci assembly +# =========================================================================== + +test_that("combining fits with no top_loci yields the empty table, not NULL", { + # The empty table keeps its full column set, so downstream binds and + # column selections still work on a result that found nothing. + out <- pecotmr:::.ppFitsCombine(list(list(a = 1), list(b = 2))) + expect_s3_class(out$top_loci, "tbl_df") + expect_equal(nrow(out$top_loci), 0L) + expect_gt(ncol(out$top_loci), 0L) +}) + +test_that("the fit region spans one chromosome or is refused", { + r <- pecotmr:::.csVariantRegion(c("chr1:100:A:G", "chr1:200:C:T")) + expect_s4_class(r, "GRanges") + expect_equal(as.character(GenomicRanges::seqnames(r)), "chr1") + # Variants on two chromosomes have no single region to pull LD for. + expect_error( + pecotmr:::.csVariantRegion(c("chr1:100:A:G", "chr2:200:C:T")), + "fit variants span multiple chromosomes" + ) +}) + +test_that("credible-set genotypes must cover every fit variant", { + # Silently correlating a subset would report a purity for a set the + # genotypes cannot actually measure. + data(qtlDatasetExample) + expect_error( + pecotmr:::.csGenotypesForFit( + qtlDatasetExample, + c("chr22:1:A:G", "chr22:2:C:T") + ), + "fit variant\\(s\\) absent from the QtlDataset genotypes" + ) +}) + + +test_that("buildTopLoci on no variants returns the empty table", { + out <- buildTopLoci( + fit = list(), + csTables = list(), + variantNames = character(0), + method = "susie" + ) + expect_s3_class(out, "tbl_df") + expect_equal(nrow(out), 0L) + expect_gt(ncol(out), 0L) +}) + +test_that("the multi-CS warning falls back to a positional variant label", { + # With no variant names the warning still has to identify which variant, + # so it reports # rather than an empty or NA name. + expect_warning( + pecotmr:::.fmWarnMultiCs( + memb = list(integer(0), c(1L, 2L)), + out = c(0L, 1L), + bestSize = c(0L, 2L), + sets = set_names(list(1:2, 3:4), c("L1", "L2")), + variantNames = NULL + ), + "Variant #2 is in multiple credible sets: L1, L2" + ) + # With names it uses the name. + expect_warning( + pecotmr:::.fmWarnMultiCs( + memb = list(integer(0), c(1L, 2L)), + out = c(0L, 1L), + bestSize = c(0L, 2L), + sets = set_names(list(1:2, 3:4), c("L1", "L2")), + variantNames = c("chr1:100:A:G", "chr1:200:C:T") + ), + "Variant chr1:200:C:T is in multiple credible sets" + ) +}) + + +# =========================================================================== +# fSuSiE weight shaping +# =========================================================================== + +test_that("fsusie weight rownames fall back through the fit's own names", { + # Three sources in priority order, because a trimmed fit may have dropped + # whichever one the caller expected. Unnamed weights would silently + # misalign against the variant set downstream. + W <- matrix(0, 3L, 2L) + expect_equal( + rownames(pecotmr:::.fsusieWeightsNames( + W, + list(), + c("v1", "v2", "v3"), + NULL, + 3L, + 2L + )), + c("v1", "v2", "v3") + ) + expect_equal( + rownames(pecotmr:::.fsusieWeightsNames( + W, + list(csd_X = set_names(1:3, c("c1", "c2", "c3"))), + NULL, + NULL, + 3L, + 2L + )), + c("c1", "c2", "c3") + ) + expect_equal( + rownames(pecotmr:::.fsusieWeightsNames( + W, + list(pip = set_names(c(0.1, 0.2, 0.3), c("p1", "p2", "p3"))), + NULL, + NULL, + 3L, + 2L + )), + c("p1", "p2", "p3") + ) + # No source at all: left unnamed rather than given made-up names. + expect_null( + rownames(pecotmr:::.fsusieWeightsNames(W, list(), NULL, NULL, 3L, 2L)) + ) +}) + +test_that("the fsusie fast path uses a trimmed fit's precomputed coef", { + # fineMappingPipeline computes coef eagerly before trimming drops + # fitted_wc, so a trimmed fit needs no wavelet reconstruction at all. + cf <- matrix(1:6, 3L, 2L) + W <- pecotmr:::.fsusieWeightsFastPath( + list(coef = cf, fitted_wc = NULL), + c("a", "b", "c"), + retainFit = TRUE + ) + expect_equal(rownames(W), c("a", "b", "c")) + expect_false(is.null(attr(W, "fit"))) + # A fit that still carries fitted_wc is NOT the fast path. + expect_null(pecotmr:::.fsusieWeightsFastPath( + list(coef = cf, fitted_wc = list(1)), + c("a", "b", "c"), + retainFit = FALSE + )) +}) + + +# =========================================================================== +# Per-token fit dispatch +# +# susieInf is fitted whenever another token chains from it, but it is only +# EMITTED as its own result when the caller asked for it. These are the two +# arms of that distinction. +# =========================================================================== + +test_that("susieInf is skipped as a result when it was only a chain input", { + # Requesting susie alone with addSusieInf still fits an inf model to chain + # from, but keepInf is FALSE so it must not surface as its own method. + chainOnly <- pecotmr:::.fmResolveSusieChain("susie", TRUE) + expect_false(chainOnly$keepInf) + expect_null(pecotmr:::.fmXFitOne("susieInf", list(), chainOnly, "INFFIT")) + expect_null(pecotmr:::.fmRssFitOne("susieInf", list(), chainOnly, "INFFIT")) +}) + +test_that("susieInf is returned as its own fit when it was requested", { + asked <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) + expect_true(asked$keepInf) + expect_equal( + pecotmr:::.fmXFitOne("susieInf", list(), asked, "INFFIT"), + "INFFIT" + ) + rss <- pecotmr:::.fmRssFitOne("susieInf", list(), asked, "INFFIT") + expect_equal(rss$fit, "INFFIT") + expect_false(rss$isStd) +}) + + +# =========================================================================== +# Full-fit column assembly +# =========================================================================== + +test_that("variant count falls back to the CS vector when alpha is unusable", { + # A NULL or 1-D alpha carries no variant axis, so the row count has to + # come from the per-variant CS positions instead -- otherwise the block + # would be the wrong length and misalign against its siblings. + f <- pecotmr:::.fullFitColumns + expect_equal( + nrow(f( + alpha = NULL, + mu = NULL, + scale = NULL, + primaryCsPos = c(0L, 1L, 0L), + effectOf = 1L + )), + 3L + ) + expect_equal( + nrow(f( + alpha = c(0.5, 0.5), + mu = NULL, + scale = NULL, + primaryCsPos = c(0L, 1L), + effectOf = 1L + )), + 2L + ) +}) + +test_that("includeAllCs widens to every effect rather than the kept ones", { + # Without it only effects that survived CS filtering get columns; with it + # every row of alpha does, labelled L1..Lk. + a <- matrix(c(0.3, 0.7, 0.6, 0.4), nrow = 2L, byrow = TRUE) + out <- pecotmr:::.fullFitColumns( + alpha = a, + mu = a, + scale = c(1, 1), + primaryCsPos = c(0L, 1L), + effectOf = c(1L, 2L), + fullFit = TRUE, + includeAllCs = TRUE + ) + expect_equal(nrow(out), 2L) + expect_gt(ncol(out), 1L) +}) + +test_that("susie weight extraction can carry the fit alongside the weights", { + w <- pecotmr:::.susieExtractWeights( + fit = list(pip = c(0.1, 0.2)), + X = NULL, + y = NULL, + requiredFields = "absentField", + retainFit = TRUE + ) + expect_equal(attr(w, "fit")$pip, c(0.1, 0.2)) + # Without the required fields the weights are zero, not an error. + expect_equal(as.numeric(w), c(0, 0)) +}) + + +# =========================================================================== +# Conditional lfsr fill +# =========================================================================== + +test_that("conditional lfsr is filled from the primary credible set", { + # Each variant takes the lfsr of the effect its primary-coverage CS + # belongs to; variants in no set stay NA rather than borrowing one. + clf <- array(0.05, dim = c(2L, 3L, 1L)) + tbl <- list(list(sets = list(cs = set_names(list(c(1L, 2L)), "L1")))) + out <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.95, + csTables = tbl, + nV = 3L + ) + expect_equal(out[1:2], c(0.05, 0.05)) + expect_true(is.na(out[[3L]])) +}) + +test_that("a credible set naming an out-of-range effect is skipped", { + # L9 against a 2-effect lfsr array would index out of bounds; the set is + # skipped so the remaining sets still fill, rather than erroring. + clf <- array(0.05, dim = c(2L, 3L, 1L)) + tbl <- list(list(sets = list(cs = set_names(list(c(1L, 2L)), "L9")))) + out <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.95, + csTables = tbl, + nV = 3L + ) + expect_true(all(is.na(out))) +}) + +test_that("no credible sets leaves the conditional lfsr untouched", { + clf <- array(0.05, dim = c(2L, 3L, 1L)) + tbl <- list(list(sets = list(cs = list()))) + out <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.95, + csTables = tbl, + nV = 3L + ) + expect_true(all(is.na(out))) +}) + +# --------------------------------------------------------------------------- +# susieInf chaining and per-token skips: a chained token reuses the shared +# susieInf fit, and a token that produces no fit drops out of the block. +# --------------------------------------------------------------------------- + +test_that(".fmXFitOne threads the shared susieInf fit into chained tokens", { + local_mocked_bindings( + .fmFitSusieIndiv = function(X, y, tk, chainFromInf, coverage, + userArgs) { + list(tk = tk, chained = !is.null(chainFromInf)) + }, + .package = "pecotmr" + ) + p <- list( + X = NULL, y = NULL, verbose = 0, coverage = 0.95, + methodArgs = list(), ctx = "c1", tid = "t1" + ) + chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) + expect_true(chain$chainSusie) + expect_true(pecotmr:::.fmXFitOne("susie", p, chain, list(S = TRUE))$chained) + # susieAsh is not in this chain, so it fits from scratch. + expect_false( + pecotmr:::.fmXFitOne("susieAsh", p, chain, list(S = TRUE))$chained + ) + chainAsh <- pecotmr:::.fmResolveSusieChain(c("susieAsh", "susieInf"), TRUE) + expect_true( + pecotmr:::.fmXFitOne("susieAsh", p, chainAsh, list(S = TRUE))$chained + ) +}) + +test_that(".fmFitXBlock skips a token that produced no fit", { + local_mocked_bindings( + .fmXInfFit = function(p, chainLocal) NULL, + .fmXFitOne = function(tk, p, chainLocal, infFit) { + if (tk == "susie") NULL else list(tk = tk) + }, + .fmXPostprocess = function(fit, tk, p) list(done = tk), + .fmXCrossValidate = function(out, p) out, + .package = "pecotmr" + ) + out <- pecotmr:::.fmFitXBlock( + X = NULL, + y = NULL, + toRun = c("susie", "lasso"), + addSusieInf = FALSE + ) + # The NULL-fit token contributes no entry rather than an empty one. + expect_equal(names(out), "lasso") +}) + +test_that(".fmRssFitStd threads the shared susieInf fit when chained", { + local_mocked_bindings( + .fmFitSusieRss = function(z, R, n, tk, chainFromInf, coverage, + userArgs, rFinite, rMismatch, rssControl) { + list(tk = tk, chained = !is.null(chainFromInf)) + }, + .package = "pecotmr" + ) + p <- list( + z = NULL, R = NULL, n = 100L, verbose = 0, coverage = 0.95, + methodArgs = list(), label = "lab", rFinite = NULL, + rMismatch = NULL, rssControl = NULL + ) + chain <- pecotmr:::.fmResolveSusieChain(c("susie", "susieInf"), TRUE) + out <- pecotmr:::.fmRssFitStd("susie", p, chain, list(S = TRUE)) + expect_true(out$fit$chained) +}) + +test_that(".fmFitRssBlock skips a token that produced no fit", { + local_mocked_bindings( + .fmRssInfFit = function(p, chainLocal) NULL, + .fmRssFitOne = function(tk, p, chainLocal, infFit) { + if (tk == "susie") { + NULL + } else { + list(fit = list(tk = tk), isStd = FALSE) + } + }, + .fmRssPostprocess = function(fit, p) list(done = fit$tk), + .package = "pecotmr" + ) + out <- pecotmr:::.fmFitRssBlock( + z = NULL, + R = NULL, + n = 100L, + toRun = c("susie", "susieAsh"), + addSusieInf = FALSE + ) + expect_equal(names(out), "susieAsh") +}) + +test_that("computeCsTables falls back to 0.95 when nothing supplies coverage", { + skip_if_not_installed("susieR") + d <- .make_univariate_data(seed = 7, n = 200, p = 8, effect_idx = c(2)) + fit <- susieR::susie(d$X, d$y, L = 4) + # Neither the argument nor the fit names a coverage. + fit$sets$requested_coverage <- NULL + cts <- pecotmr:::computeCsTables( + fit, + d$X, + coverage = NULL, + secondaryCoverage = 0.5, + method = "susie", + csInput = "X" + ) + expect_equal(attr(cts, "coverage"), c(0.95, 0.5)) + expect_equal(names(cts), c("CS_95_susie", "CS_50_susie")) +}) + +test_that(".ppAssembleRes records sample names from a matrix dataY", { + Y <- matrix( + 1:6, + nrow = 3L, + dimnames = list(c("s1", "s2", "s3"), c("a", "b")) + ) + p <- list( + signalCutoff = 0, method = "susie", dataY = Y, + fit = list(), otherQuantities = NULL + ) + topLoci <- data.frame( + variant_id = "chr1:1:A:G", + pip = 0.9, + stringsAsFactors = FALSE + ) + res <- pecotmr:::.ppAssembleRes(p, topLoci, NULL, NULL) + expect_equal(res$sampleNames, c("s1", "s2", "s3")) + # A list dataY (multi-context) has no single sample vector to record. + expect_null(pecotmr:::.sampleNamesFromDataY(list(Y))) +}) + +test_that(".btlParseVariants surfaces a parse failure as an error", { + local_mocked_bindings( + parseVariantId = function(...) stop("boom"), + .package = "pecotmr" + ) + expect_error( + pecotmr:::.btlParseVariants("chr1:1:A:G"), + "buildTopLoci: parseVariantId failed: boom" + ) +}) + +test_that(".btlParseVariants requires one parsed row per variant", { + local_mocked_bindings( + parseVariantId = function(v) { + data.frame(chrom = "chr1", pos = 1L, A1 = "A", A2 = "G") + }, + .package = "pecotmr" + ) + expect_error( + pecotmr:::.btlParseVariants(c("chr1:1:A:G", "chr1:2:C:T")), + "did not return one row per variant" + ) +}) + +test_that(".btlCondLfsr yields all-NA when the primary CS is empty", { + clf <- array(0.05, dim = c(1L, 3L, 1L)) + tables <- list(list(sets = list(cs = list()))) + out <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.95, + csTables = tables, + nV = 3L + ) + expect_length(out, 3L) + expect_true(all(is.na(out))) +}) + +.fmw_pipRow <- function() { + fineMappingRow( + variantIds = c("chr1:100:A:G", "chr1:200:C:T"), + susieFit = list(pip = c(0.8, 0.2)), + topLoci = data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + pip = c(0.8, 0.2), + stringsAsFactors = FALSE + ) + ) +} + +test_that("mergeSusieCs returns NULL when no row carries a credible set", { + res <- GwasFineMappingResult( + study = "G1", + method = "susie", + entry = list(.fmw_pipRow()) + ) + # The rows have pip but no cs_95 column, so nothing is extracted. + expect_null(mergeSusieCs(res, coverage = 0.95)) +}) + +test_that(".extractCsEntryRows needs a resolvable pip column", { + topLoci <- data.frame( + variant_id = c("v1", "v2"), + cs_95 = c(1L, 1L), + beta = c(1, 2), + stringsAsFactors = FALSE + ) + local_mocked_bindings( + .fmrRowTopLoci = function(e) topLoci, + .package = "pecotmr" + ) + # The credible-set column is present, but there is no pip to rank by. + expect_null(pecotmr:::.extractCsEntryRows(1L, list("dummy"), "cs_95")) +}) + +test_that("getSusieResult returns NULL for an empty susie fit", { + expect_null(getSusieResult(list())) + expect_null(getSusieResult(list(a = 1))) + row <- fineMappingRow( + variantIds = "chr1:1:A:G", + susieFit = list(), + topLoci = data.frame( + variant_id = "chr1:1:A:G", + pip = 0.5, + stringsAsFactors = FALSE + ) + ) + res <- GwasFineMappingResult( + study = "G1", + method = "susie", + entry = list(row) + ) + # A FineMappingResult is present, but it carries no fit to return. + expect_null(getSusieResult(list(finemappingEntry = res))) +}) + +test_that(".btlFullFitBlock defaults the primary CS position to zeros", { + cs <- list(csIdxByCov = list(), covSorted = numeric(0)) + out <- pecotmr:::.btlFullFitBlock( + fit = list(), + post = list(), + coverageValues = numeric(0), + cs = cs, + csTables = list(), + nV = 4L, + opts = list() + ) + # No credible sets at any coverage: every variant gets CS position 0. + expect_equal(nrow(out), 4L) +}) + +test_that(".fsusieScaleCols reads the wavelet columns off a flat prior", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + obj <- .fw_makeFsusieFit(prior = "mixture_normal") + expect_false( + is_in( + "mixture_normal_per_scale", + class(fsusieR::get_G_prior(obj$fit)) + ) + ) + # A flat prior has no per-scale index to read, so the column count comes + # from the fitted wavelet coefficients themselves. + expect_equal( + pecotmr:::.fsusieScaleCols(obj$fit), + ncol(as.matrix(obj$fit$fitted_wc[[1L]])) + ) + W <- fsusieWeights(fsusieFit = obj$fit, variantIds = colnames(obj$X)) + expect_equal(dim(W), c(ncol(obj$X), ncol(obj$Y))) +}) + +test_that("fsusieWeights attaches the fit only when asked", { + skip_if_not_installed("fsusieR") + skip_if_not_installed("wavethresh") + obj <- .fw_makeFsusieFit() + kept <- fsusieWeights( + fsusieFit = obj$fit, + variantIds = colnames(obj$X), + retainFit = TRUE + ) + expect_false(is.null(attr(kept, "fit"))) + plain <- fsusieWeights(fsusieFit = obj$fit, variantIds = colnames(obj$X)) + expect_null(attr(plain, "fit")) +}) + +test_that("mvsusieRssWeights attaches the fit only when asked", { + skip_if_not_installed("mvsusieR") + m <- .rrwMulti(n = 80, p = 8, K = 2) + kept <- suppressMessages( + mvsusieRssWeights(m$stat, m$LD, L = 5, retainFit = TRUE) + ) + expect_false(is.null(attr(kept, "fit"))) + expect_equal(dim(kept), c(m$p, m$K)) +}) + +test_that(".rowCsCorrelation dispatches a QtlDataset to the genotype path", { + data(qtlDatasetExample) + local_mocked_bindings( + .rowCsCorrelationGeno = function(parts, ldSource) "GENO_PATH", + .package = "pecotmr" + ) + # Individual-level data reads LD from dosage, not from summary stats. + expect_equal( + pecotmr:::.rowCsCorrelation(list(), qtlDatasetExample), + "GENO_PATH" + ) +}) + +test_that(".btlCondLfsr is all-NA when no table matches the primary coverage", { + clf <- array(0.05, dim = c(1L, 3L, 1L)) + tables <- list(list(sets = list(cs = list(L1 = 1:2)))) + # covSorted names 0.70 but the only computed table is at 0.95, so there + # is no primary table to read the conditional lfsr out of. + out <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.70, + csTables = tables, + nV = 3L + ) + expect_true(all(is.na(out))) + # Control: when the coverages line up, the CS members are filled. + filled <- pecotmr:::.btlCondLfsr( + list(clfsr = clf), + conditionIdx = 1L, + coverageValues = 0.95, + covSorted = 0.95, + csTables = tables, + nV = 3L + ) + expect_equal(filled[1:2], c(0.05, 0.05)) + expect_true(is.na(filled[[3L]])) +}) + +test_that("mergeSusieCs returns NULL when the combined table is empty", { + local_mocked_bindings( + .fmExtractTopLoci = function(fineMappingResult, csCol) list(a = 1), + .combineTopLoci = function(x) NULL, + .package = "pecotmr" + ) + res <- GwasFineMappingResult( + study = "G1", + method = "susie", + entry = list(.fmw_pipRow()) + ) + # Rows were extracted, but combining them produced nothing to merge. + expect_null(mergeSusieCs(res, coverage = 0.95)) +}) diff --git a/tests/testthat/test_genotypeHandle.R b/tests/testthat/test_genotypeHandle.R index 1e8260e9..2fd48034 100644 --- a/tests/testthat/test_genotypeHandle.R +++ b/tests/testthat/test_genotypeHandle.R @@ -897,3 +897,25 @@ test_that("only the requested variants are read", { test_that("genotypeDelayedArray rejects a non-handle", { expect_error(genotypeDelayedArray("not a handle"), "GenotypeHandle") }) + + +test_that("the resource-path resolver passes non-scalar and NA paths through", { + # Only a length-1 non-NA string can carry a "pecotmr://" reference, so + # anything else is returned untouched rather than matched against. + f <- pecotmr:::.resolveGenotypeResourcePath + expect_identical(f(NA_character_), NA_character_) + expect_length(f(character(0)), 0L) + expect_identical(f(c("a", "b")), c("a", "b")) + # ...and an ordinary scalar path still comes back unchanged. + expect_identical(f("/tmp/plink"), "/tmp/plink") +}) + + +test_that("an unresolvable bundled resource reference is an error", { + expect_error( + pecotmr:::.resolveGenotypeResourcePath( + "pecotmr://extdata/no_such_resource_anywhere" + ), + "cannot resolve bundled genotype resource" + ) +}) diff --git a/tests/testthat/test_genotypeIo.R b/tests/testthat/test_genotypeIo.R index da47b9cc..97a2f131 100644 --- a/tests/testthat/test_genotypeIo.R +++ b/tests/testthat/test_genotypeIo.R @@ -2510,3 +2510,172 @@ test_that("readGenotypes reaches the explicit-triplet source too", { expect_s4_class(panel, "RangedSummarizedExperiment") expect_equal(dim(panel), dim(readGenotypes(stem, format = "plink1"))) }) + + +# =========================================================================== +# Format detection and handle/covariate helpers +# +# The extension->format switch had only two of its fourteen arms exercised, +# and the NULL-safe / legacy-handle / covariate-alignment branches none. +# =========================================================================== + +test_that("every file extension maps to its genotype format", { + f <- pecotmr:::.h2FormatFromExt + expect_equal(f("vcf"), "vcf") + expect_equal(f("bcf"), "vcf") + expect_equal(f("bed"), "plink1") + expect_equal(f("bim"), "plink1") + expect_equal(f("fam"), "plink1") + expect_equal(f("pgen"), "plink2") + expect_equal(f("pvar"), "plink2") + expect_equal(f("psam"), "plink2") + expect_equal(f("gds"), "gds") + expect_equal(f("rds"), "rds") + expect_equal(f("rdata"), "rds") + expect_equal(f("annot"), "ldsc_annot") + expect_equal(f("bw"), "bigwig") + expect_equal(f("bigwig"), "bigwig") + # An unrecognised extension is NULL, not an error: the caller decides. + expect_null(f("zzz")) +}) + +test_that("the unsupported-format signaller names its context when given one", { + expect_error( + pecotmr:::.abortUnsupportedFormat("weird", "myContext"), + "Unsupported format in myContext: weird" + ) + expect_error( + pecotmr:::.abortUnsupportedFormat("weird"), + "Unsupported genotype format: weird" + ) +}) + +test_that("the handle helpers are NULL-safe", { + expect_null(pecotmr:::.emptyGenotypeHandle(NULL)) + expect_null(pecotmr:::.subsetGenotypeHandle(NULL, 1L)) +}) + +test_that("a legacy handle without fileIdx is not subset", { + # Without fileIdx there is no way to keep on-disk positions correct after + # dropping rows, so the handle is returned whole rather than silently + # mis-indexed. + h <- new( + "GenotypeHandle", + path = "/tmp/x.gds", + format = "gds", + snpInfo = data.frame( + SNP = c("a", "b", "c"), + CHR = "1", + BP = 1:3, + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ), + nSamples = 2L, + sampleIds = c("s1", "s2"), + pgenPtr = NULL + ) + sub <- pecotmr:::.subsetGenotypeHandle(h, 1L) + expect_equal(nrow(pecotmr:::getSnpInfo(sub)), 3L) +}) + +test_that("covariate colData aligns to the panel's samples", { + f <- pecotmr:::.genotypeColData + ids <- c("s1", "s2") + # No covariates at all: an empty DataFrame that still names the samples. + empty <- f(matrix(numeric(0), 0L, 0L), ids) + expect_equal(rownames(empty), ids) + expect_equal(ncol(empty), 0L) + # Unnamed rows of the right length are taken positionally. + cd <- f(matrix(1:2, 2L, 1L, dimnames = list(NULL, "pc1")), ids) + expect_equal(rownames(cd), ids) + expect_equal(as.numeric(cd$pc1), c(1, 2)) + # Unnamed rows of the WRONG length are an error, not a silent recycle. + expect_error( + f(matrix(1, 3L, 1L), ids), + "has 3 rows but the panel has 2 samples" + ) +}) + + +test_that("a panel with no covariates gets an empty colData", { + prefix <- sub( + "\\.bed$", + "", + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) + panel <- readGenotypes(plink1Prefix = prefix) + out <- pecotmr:::.genotypeExperimentCovariates(panel, NULL) + cd <- SummarizedExperiment::colData(out) + expect_equal(ncol(cd), 0L) + # The samples are still named, so the assay keeps a column for each. + expect_equal(rownames(cd), colnames(panel)) +}) + +test_that("block extraction rejects a format it has no reader for", { + # The constructor rejects an unknown format outright, so this guard can + # only be reached by a direct slot set -- which is exactly what it exists + # to catch. + h <- new( + "GenotypeHandle", + path = "/tmp/x.gds", + format = "gds", + snpInfo = data.frame( + SNP = "a", + CHR = "1", + BP = 1L, + A1 = "A", + A2 = "G", + fileIdx = 1L, + stringsAsFactors = FALSE + ), + nSamples = 1L, + sampleIds = "s1", + pgenPtr = NULL + ) + expect_error( + new( + "GenotypeHandle", + path = "/tmp/x", + format = "zzz", + snpInfo = getSnpInfo(h), + nSamples = 1L, + sampleIds = "s1", + pgenPtr = NULL + ), + "'format' must be one of" + ) + h@format <- "zzz" + expect_error( + pecotmr:::.extractBlockByFormat(h, 1L), + "Unsupported format in extractBlockGenotypes: zzz" + ) +}) + +test_that("stochastic inversion is a no-op when no id matches the metadata", { + # The metadata exists and parses, but names other variants entirely, so + # there is nothing to invert and the result passes through untouched. + meta <- withr::local_tempfile(fileext = ".stochastic_meta.tsv") + readr::write_tsv( + data.frame( + id = c("other1", "other2"), + u_min = c(0, 0), + u_max = c(1, 1) + ), + meta + ) + X <- matrix( + 1:4, + 2L, + 2L, + dimnames = list(c("s1", "s2"), c("v1", "v2")) + ) + res <- list(X = X) + out <- pecotmr:::.loadGenoInvertStochastic( + res, + genotype = "/tmp/does_not_matter", + stochasticMetaPath = meta, + stochasticMetaFormat = "generic" + ) + expect_identical(out$X, X) +}) diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index da310dc5..f9758790 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -477,6 +477,335 @@ test_that("estimateh2 with method='lder' returns H2Estimate with correct slots", expect_equal(getTraitName(result), "test") }) +# =========================================================================== +# estimateH2 input alignment +# +# The estimators index z and the annotation rows by each LD block's snpIdx, +# matching nothing on variant id, so a misaligned input used to return a +# silently wrong h2 instead of failing. +# =========================================================================== + +# Rebuild `ss`'s single entry with the mcols kept and the ranges replaced. +.reposition <- function(ss, gr) { + entry <- getSumStats(ss) + S4Vectors::mcols(gr) <- S4Vectors::mcols(entry) + GwasSumStats( + study = "test", + entry = list(gr), + genome = "hg19", + ldSketch = make_test_gwas_genotype_handle() + ) +} + +test_that("estimateH2 rejects a sumstats with a different variant count", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + short <- GwasSumStats( + study = "test", + entry = list(getSumStats(ss)[1:10]), + genome = "hg19", + ldSketch = make_test_gwas_genotype_handle() + ) + expect_error( + estimateH2(short, ref, method = "lder"), + "carries 10 variant\\(s\\) but the LD reference carries 20" + ) +}) + +test_that("estimateH2 rejects a sumstats at different coordinates", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + shifted <- .reposition( + ss, + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(GenomicRanges::start(ref) + 1L, width = 1L) + ) + ) + expect_error( + estimateH2(shifted, ref, method = "lder"), + "disagree at 20 of 20 position" + ) +}) + +test_that("estimateH2 rejects a sumstats holding the right variants in the wrong order", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + reordered <- .reposition( + ss, + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(rev(GenomicRanges::start(ref)), width = 1L) + ) + ) + expect_error( + estimateH2(reordered, ref, method = "lder"), + "same variants in the same order" + ) +}) + +test_that("estimateH2 rejects annotations that do not cover the reference", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + annot <- make_test_annotations(nSnps = 10) + expect_error( + estimateH2(ss, ref, method = "lder", annotations = annot), + "`annotations` carries 10 variant\\(s\\)" + ) +}) + +test_that("estimateH2 rejects a genome build mismatch", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + hg38 <- GwasSumStats( + study = "test", + entry = list(getSumStats(ss)), + genome = "hg38", + ldSketch = make_test_gwas_genotype_handle() + ) + expect_error(estimateH2(hg38, ref, method = "lder"), "build mismatch") +}) + +test_that("estimateH2 accepts an LD reference that records no genome build", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + # loadLdMatrix() leaves the build unset, so a reference built from it + # names none. An unknown build must not read as a mismatch. + GenomeInfoDb::genome(ref) <- NA_character_ + expect_s4_class(estimateH2(ss, ref, method = "lder"), "H2Estimate") +}) + +# =========================================================================== +# S-LDSC (Finucane et al. 2015) +# +# The original stratified LD score regression, added alongside the three +# newer estimators. Unlike g-LDSC it regresses chi2 on per-variant LD scores +# rather than working from the per-block LD matrices, so an unstratified run +# needs only the scores. +# =========================================================================== + +test_that("unstratified S-LDSC runs without the per-block LD matrices", { + # This is the property that separates it from g-LDSC: a scores-only + # LdScore is enough, which is why it is the cheap option. + noMat <- make_test_score_ref(with_ld_matrices = FALSE) + ss <- make_test_sumstats_for_ref(noMat) + expect_error(estimateH2(ss, noMat, method = "gldsc"), "per-block LD") + res <- estimateH2(ss, noMat, method = "sldsc") + expect_s4_class(res, "H2Estimate") + expect_equal(getMethodNames(res), "sldsc") + expect_true(is.finite(getH2(res))) +}) + +test_that("stratified S-LDSC needs the per-block LD matrices", { + noMat <- make_test_score_ref(with_ld_matrices = FALSE) + ss <- make_test_sumstats_for_ref(noMat) + annot <- make_test_annotations(nSnps = length(noMat)) + expect_error( + estimateH2(ss, noMat, method = "sldsc", annotations = annot), + "stratified S-LDSC requires full per-block LD matrices" + ) +}) + +test_that("S-LDSC reports an enrichment table when stratified", { + ref <- make_test_score_ref(with_ld_matrices = TRUE) + ss <- make_test_sumstats_for_ref(ref) + annot <- make_test_annotations(nSnps = length(ref)) + res <- estimateH2(ss, ref, method = "sldsc", annotations = annot) + + enr <- getEnrichment(res) + expect_s3_class(enr, "data.frame") + expect_equal(nrow(enr), 2L) + expect_true(all( + c( + "annotation", + "tau", + "tauSe", + "enrichment", + "enrichmentSe", + "enrichmentP", + "propH2", + "propSnps" + ) %in% + names(enr) + )) + expect_false(is.null(getTauBlocks(res))) +}) + +test_that("S-LDSC requires an LdScore, not an LdEigen", { + eigenRef <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(eigenRef) + expect_error( + estimateH2(ss, eigenRef, method = "sldsc"), + "requires an LdScore" + ) +}) + +test_that("the S-LDSC weights reproduce upstream Hsq.weights", { + # het_w = 1 / (2 (intercept + hsq*N/M * ld)^2), oc_w = 1 / w_ld, both + # LD scores floored at 1 and hsq clamped to [0, 1]. + w <- pecotmr:::.sldscWeights( + ld = c(4, 1, 0.5), + wLd = c(10, 1, 0.2), + n = 1000, + M = 100, + hsq = 0.5, + intercept = 1 + ) + cc <- 0.5 * 1000 / 100 + expected <- (1 / (2 * (1 + cc * c(4, 1, 1))^2)) / c(10, 1, 1) + expect_equal(w, expected) + expect_true(all(w > 0)) + + # hsq is clamped, so an out-of-range estimate cannot blow the weights up. + expect_equal( + pecotmr:::.sldscWeights(2, 1, 1000, 100, hsq = 5, intercept = 1), + pecotmr:::.sldscWeights(2, 1, 1000, 100, hsq = 1, intercept = 1) + ) + expect_equal( + pecotmr:::.sldscWeights(2, 1, 1000, 100, hsq = -3, intercept = 1), + pecotmr:::.sldscWeights(2, 1, 1000, 100, hsq = 0, intercept = 1) + ) +}) + +# =========================================================================== +# Rank-deficient LD +# +# A real LD block is routinely rank-deficient, and its decomposition then +# carries a tail of tiny negative eigenvalues (order -1e-15) that are pure +# floating-point noise. Those used to reach .lderWeights() as negative +# regression weights, so IRWLS took sqrt() of a negative and lm.fit aborted +# with "NA/NaN/Inf in 'x'". +# =========================================================================== + +# An LD block with `dup` variants repeated, so R is singular by construction +# and eigen() returns a negative-noise tail. +.rankDeficientEigenRef <- function(nBlocks = 6L, p = 12L, dup = 4L) { + blocks <- lapply(seq_len(nBlocks), function(b) { + base <- 0.5^abs(outer(seq_len(p - dup), seq_len(p - dup), "-")) + keep <- c(seq_len(p - dup), seq_len(dup)) + R <- base[keep, keep] + e <- eigen(R, symmetric = TRUE) + list( + values = e$values, + vectors = e$vectors, + snpIdx = as.integer(((b - 1L) * p + 1L):(b * p)) + ) + }) + M <- nBlocks * p + snpInfo <- data.frame( + SNP = paste0("rs", seq_len(M)), + CHR = "chr1", + BP = as.integer(seq_len(M) * 100L), + A1 = "A", + A2 = "G", + stringsAsFactors = FALSE + ) + starts <- as.integer(sapply(blocks, function(b) min(b$snpIdx))) * 100L + ends <- as.integer(sapply(blocks, function(b) max(b$snpIdx))) * 100L + LdEigen( + ldBlocks = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(start = starts, end = ends) + ), + snpInfo = snpInfo, + nRef = 500000L, + inSample = FALSE, + genome = "hg19", + eigenvalueTruncation = 1.0, + eigenList = blocks + ) +} + +test_that("a rank-deficient LD block really does yield negative eigenvalues", { + ref <- .rankDeficientEigenRef() + values <- unlist(lapply(getEigenList(ref), function(b) b$values)) + expect_true(any(values < 0)) + expect_true(min(values) > -1e-6) # noise, not structure +}) + +test_that("estimateH2 survives negative eigenvalues from rank-deficient LD", { + ref <- .rankDeficientEigenRef() + ss <- make_test_sumstats_for_ref(ref) + res <- estimateH2(ss, ref, method = "lder") + expect_s4_class(res, "H2Estimate") + expect_false(is.na(getH2(res))) +}) + +test_that(".lderWeights never returns a negative weight", { + lam <- c(2, 1, 0.5, 0, -1e-15, -3e-15) + w <- pecotmr:::.lderWeights( + lam, + matrix(1, length(lam), 1), + slopes = 0.1, + N = 1e5, + M = 1000, + rough = FALSE + ) + expect_false(any(is.na(w))) + expect_true(all(w >= 0)) + # sqrt() of these is what IRWLS forms the design from. + expect_false(any(is.na(sqrt(w)))) +}) + +# =========================================================================== +# buildLdEigen / buildLdScore -> estimateH2 round trip +# +# The builders exist so that a loaded LD reference can reach estimateH2 +# without hand-assembling S4 slots; these pin that the objects they produce +# are actually accepted, alignment guard included. +# =========================================================================== + +test_that("estimateH2 runs on references built by buildLdEigen/buildLdScore", { + ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5), rho = 0.6) + eigenRef <- buildLdEigen(ld, genome = "hg19") + scoreRef <- buildLdScore(ld, genome = "hg19") + ss <- make_test_sumstats_for_ref(eigenRef) + + expect_s4_class(estimateH2(ss, eigenRef, method = "lder"), "H2Estimate") + suppressWarnings( + expect_s4_class(estimateH2(ss, eigenRef, method = "hdl"), "H2Estimate") + ) + expect_s4_class(estimateH2(ss, scoreRef, method = "gldsc"), "H2Estimate") +}) + +test_that("estimateH2 rejects a single-block LD reference", { + # One block used to fail inside the jackknife fold fit with "'x' must be + # a matrix" (LDER, g-LDSC) or return an SE of exactly 0 (HDL). + ld <- makeTestLdData(n = 30L, rho = 0.6) + eigenRef <- buildLdEigen(ld, genome = "hg19") + ss <- make_test_sumstats_for_ref(eigenRef) + expect_error( + estimateH2(ss, eigenRef, method = "lder"), + "delete-one-block jackknife" + ) + expect_error( + estimateH2(ss, buildLdScore(ld, genome = "hg19"), method = "gldsc"), + "at least two are required" + ) +}) + +test_that("buildLdScore(keepLdMatrices = FALSE) is rejected by g-LDSC", { + ld <- makeTestLdDataMultiBlock(sizes = rep(10L, 5)) + scoreRef <- buildLdScore(ld, genome = "hg19", keepLdMatrices = FALSE) + ss <- make_test_sumstats_for_ref(scoreRef) + expect_error( + estimateH2(ss, scoreRef, method = "gldsc"), + "requires full per-block LD matrices" + ) +}) + +test_that("estimateH2 accepts a chr-prefix difference between the two sides", { + ref <- make_test_eigen_ref() + ss <- make_test_sumstats_for_ref(ref) + # make_test_sumstats_for_ref already strips the prefix ("1" vs "chr1"), + # so this pins that the check normalizes rather than rejects it. + expect_equal( + as.character(GenomicRanges::seqnames(getSumStats(ss)))[[1]], + "1" + ) + expect_s4_class(estimateH2(ss, ref, method = "lder"), "H2Estimate") +}) + test_that("estimateh2 with var_y correction runs without error", { eigen_ref <- make_test_eigen_ref() ss <- make_test_sumstats_for_ref( @@ -2078,7 +2407,13 @@ test_that("HDL uses the finite-reference correction (nRef changes h2)", { refSmall <- d$eigenRef refSmall@nRef <- 2000L h2Big <- hdlUnivariate(z, d$N, refBig)$h2 - h2Small <- hdlUnivariate(z, d$N, refSmall)$h2 + # nRef = 2000 against this N is exactly the regime where the + # finite-reference term dominates, so the fit lands on its bound and says + # so. That is the behaviour under test, not noise to be ignored. + expect_warning( + h2Small <- hdlUnivariate(z, d$N, refSmall)$h2, + "sits at the top of its range" + ) expect_gt(abs(h2Big - h2Small), 0.05) }) @@ -2108,3 +2443,635 @@ test_that("gLDSC requires full LD matrices and gives a positive jackknife SE", { expect_true(is.finite(res$h2Se)) expect_gt(res$h2Se, 0) }) + +# The two S-LDSC recovery checks live here rather than with the rest of the +# S-LDSC block because they need .h2RecoveryRefs(), defined just above. +# S-LDSC is a genome-scale method: real analyses regress over ~1M variants. +# Every reference in this suite is a few thousand, and at that size the +# intercept is not identifiable -- an unweighted OLS on the same data also +# returns an intercept above 3 against a true 1, and attenuates h2 to ~0.30. +# So these tests check that the estimator is in the right neighbourhood and +# that its machinery behaves, not that it hits the truth; the attenuation is +# a property of the data, not of the fit. +test_that("sldscUnivariate lands near a known h2 on a small reference", { + d <- .h2RecoveryRefs(N = 5000) + uni <- rep(0.4 / d$M, d$M) + set.seed(1) + ests <- replicate( + 20, + pecotmr:::sldscUnivariate(d$simZ(uni), d$N, d$scoreRef)$h2 + ) + expect_gt(mean(ests), 0.15) + expect_lt(mean(ests), 0.65) +}) + +test_that("S-LDSC tracks h2 upward when the true h2 rises", { + # The check the point estimate cannot make on this scale: whatever the + # attenuation, a bigger true h2 must give a bigger estimate. + d <- .h2RecoveryRefs(N = 5000) + set.seed(1) + low <- replicate( + 10, + pecotmr:::sldscUnivariate( + d$simZ(rep(0.1 / d$M, d$M)), + d$N, + d$scoreRef + )$h2 + ) + set.seed(1) + high <- replicate( + 10, + pecotmr:::sldscUnivariate( + d$simZ(rep(0.6 / d$M, d$M)), + d$N, + d$scoreRef + )$h2 + ) + expect_gt(mean(high), mean(low)) +}) + +test_that("the S-LDSC intercept is estimated on the low-chi2 variants", { + # Two-step: step 1 fits the intercept on chi2 < 30, step 2 holds it fixed + # while fitting the slopes. The value is reported as estimated -- upstream + # does not floor it at 1, and one below 1 is informative rather than an + # error to be clamped away. + d <- .h2RecoveryRefs(N = 5000) + set.seed(1) + res <- pecotmr:::sldscUnivariate( + d$simZ(rep(0.4 / d$M, d$M)), + d$N, + d$scoreRef + ) + expect_true(is.finite(res$intercept)) + expect_gt(res$intercept, 0) +}) + +test_that("S-LDSC recovers enrichment direction for one annotation", { + # A single annotation, not a full partition: a set of baseline columns + # that exactly partitions the variants is rank-deficient against the + # model's implicit all-ones base column, and the split between them is + # then arbitrary. Real baseline models overlap and do not partition. + d <- .h2RecoveryRefs(N = 5000) + M <- d$M + inA <- as.integer(seq_len(M) <= M / 2) + annot <- AnnotationMatrix( + matrix(inA, ncol = 1, dimnames = list(NULL, "annotA")), + GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(as.integer(seq_len(M) * 100L), width = 1L) + ), + data.frame(name = "annotA", tier = "baseline", type = "binary"), + genome = "hg19" + ) + perSnp <- ifelse(seq_len(M) <= M / 2, 0.6 / M, 0.2 / M) + set.seed(1) + e <- mean(replicate(10, { + pecotmr:::sldscUnivariate( + d$simZ(perSnp), + d$N, + d$scoreRef, + annotations = annot + )$enrichment$enrichment + })) + expect_gt(e, 1) # annotA carries 3x the per-variant heritability +}) + + +# ============================================================================= +# Numerical agreement with upstream LDSC +# +# Values below were produced by running ldsc's own `ldscore.regressions.Hsq` +# (github.com/CBIIT/ldsc) on exactly the data these tests regenerate, in the +# two configurations `ldscore/sumstats.py` selects: +# +# univariate -> Hsq(..., twostep = 30) +# partitioned -> chi2 < max(0.001 N, 80) filter, then Hsq(..., old_weights +# = True) +# +# Agreement is to about 1e-6 relative; the residual is the small ridge in +# .sldscWlsCoef(), which upstream has no equivalent of. Case 2's intercept +# sits below 1 and case 3's partitioned h2 is negative -- upstream returns +# those too, and reproducing them is the point: the implementation should +# track the reference, pathologies included. +# ============================================================================= + +# The z-scores upstream was run on: z ~ N(0, N R diag(v) R + R), drawn block +# by block over the bundled reference and PINNED as data. +# +# Read from a fixture rather than re-simulated because the draw used +# `eigen()`: z = V sqrt(D) w. eigen() fixes eigenvectors only up to sign, and +# the sign LAPACK returns differs between builds, so the same seed produced +# different z -- and therefore different estimates -- on linux-64 than on +# osx-arm64 / linux-aarch64. The comparisons above are only meaningful +# against the exact vectors upstream was run on, so those are stored. +# +# Rebuild with inst/scripts/build_sldsc_upstream_z.R, and ONLY together with +# re-deriving the upstream values: the data and the expected numbers are a +# matched pair. +.sldscUpstreamZ <- function(ref, h2, n, seed) { + key <- paste(h2, n, seed, sep = "_") + zAll <- readRDS(test_path("test_data", "sldscUpstreamZ.rds")) + if (!(key %in% names(zAll))) { + stop("no pinned z-scores for case '", key, "'") + } + zAll[[key]] +} + +test_that("univariate S-LDSC reproduces upstream ldsc to 1e-5", { + data(ldScoreExample) + ref <- ldScoreExample + M <- length(ref) + scores <- matrix(as.vector(getLdScores(ref)[, 1]), ncol = 1) + baseScore <- as.vector(getLdScores(ref)[, 1]) + + reference <- list( + list( + h2 = 0.4, + n = 10000, + seed = 42, + h2Hat = 0.300334136, + int = 5.736461154 + ), + list( + h2 = 0.15, + n = 4000, + seed = 7, + h2Hat = 0.152728247, + int = 0.780709941 + ), + list( + h2 = 0.6, + n = 25000, + seed = 99, + h2Hat = 0.503086101, + int = 8.456195324 + ) + ) + for (g in reference) { + z <- .sldscUpstreamZ(ref, g$h2, g$n, g$seed) + fit <- pecotmr:::.sldscFit( + z^2, + scores, + baseScore, + g$n, + matrix(1, M, 1), + 2L + ) + expect_equal(fit$h2, g$h2Hat, tolerance = 1e-5) + expect_equal(fit$intercept, g$int, tolerance = 1e-5) + } +}) + +test_that("partitioned S-LDSC reproduces upstream ldsc to 1e-5", { + data(ldScoreExample) + ref <- ldScoreExample + 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) + + reference <- list( + list( + h2 = 0.4, + n = 10000, + seed = 42, + h2Hat = 0.361252238, + int = 2.027277477 + ), + list( + h2 = 0.15, + n = 4000, + seed = 7, + h2Hat = 0.146509163, + int = 0.858189571 + ), + list( + h2 = 0.6, + n = 25000, + seed = 99, + h2Hat = -0.043265091, + int = 22.163686076 + ) + ) + for (g in reference) { + z <- .sldscUpstreamZ(ref, g$h2, g$n, g$seed) + fit <- pecotmr:::.sldscFit(z^2, scores, scores[, 1], g$n, A, 2L) + expect_equal(fit$h2, g$h2Hat, tolerance = 1e-5) + expect_equal(fit$intercept, g$int, tolerance = 1e-5) + } +}) + +test_that("the two S-LDSC routes differ, as upstream's do", { + # Univariate takes the two-step estimator; partitioned takes the + # chi2-filtered single-pass `old_weights` route. Upstream refuses to run + # two-step on a partitioned design at all, so these must not converge to + # one shared code path. + data(ldScoreExample) + ref <- ldScoreExample + M <- length(ref) + z <- .sldscUpstreamZ(ref, 0.4, 10000, 42) + scores <- matrix(as.vector(getLdScores(ref)[, 1]), ncol = 1) + uni <- pecotmr:::.sldscFit( + z^2, + scores, + scores[, 1], + 10000, + matrix(1, M, 1), + 2L + ) + 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 + ), + scores[, 1], + 10000, + cbind(base = 1, annotA = inA), + 2L + ) + expect_false(isTRUE(all.equal(uni$intercept, part$intercept))) +}) + + +# ============================================================================= +# HDL: the finite-reference bound +# ============================================================================= + +test_that("HDL reports when its fit lands on an optimiser bound", { + # HDL subtracts lam * h2 / nRef from the modelled variance. Once the + # reference is small enough relative to the GWAS, that term outgrows the + # signal, the variance is driven negative across most directions, and the + # optimiser walks the intercept out to its upper bound -- returning a + # heritability that reflects the bound rather than the data. It used to do + # that silently. + data(ldEigenExample, ldScoreExample) + M <- length(ldScoreExample) + z <- .sldscUpstreamZ(ldScoreExample, 0.4, 1e5, 2) + + small <- ldEigenExample + small@nRef <- 1000L + expect_warning( + est <- pecotmr:::hdlUnivariate(z, 1e5, small)$h2, + "sits at the top of its range" + ) + + big <- ldEigenExample + big@nRef <- 20000L + expect_no_warning( + ok <- pecotmr:::hdlUnivariate(z, 1e5, big)$h2, + message = "sits at the top of its range" + ) + expect_gt(ok, 0.3) # recovers the simulated 0.4 + # The bound answer is simply not the data's answer -- here it overshoots, + # elsewhere it undershoots, which is the point of flagging it rather than + # asserting a direction. + expect_gt(abs(est - ok), 0.2) +}) + +test_that("HDL recovers a known h2 given an adequate reference", { + data(ldEigenExample, ldScoreExample) + ref <- ldEigenExample + ref@nRef <- 20000L + ests <- vapply( + 1:5, + function(seed) { + suppressWarnings( + pecotmr:::hdlUnivariate( + .sldscUpstreamZ(ldScoreExample, 0.4, 1e5, seed), + 1e5, + ref + )$h2 + ) + }, + numeric(1) + ) + expect_lt(abs(mean(ests) - 0.4), 0.1) +}) + + +# ============================================================================= +# Numerical agreement with the other three upstreams +# +# Values reproduce the reference implementations run on the data these tests +# regenerate: +# HDL github.com/zhenin/HDL (HDL/R/llfun.R, optimised the same way) +# LDER github.com/shuangsong0110/LDER (R/get.res.R two-stage + ldscore.R) +# gLDSC github.com/xzw20046/gldsc (R/middle_fun.R gls.left.right + +# gls.estimator) +# +# Measured agreement when this was pinned: HDL exact (0e+00), LDER machine +# precision (~1e-16), gLDSC ~3e-8 -- the last from the small ridge on the GLS +# solve, which upstream has no equivalent of. +# +# Two deliberate departures, both no-ops wherever upstream is defined: +# * LDER clamps negative eigenvalues before forming weights. Upstream does +# not, and dies with "NA/NaN/Inf in 'x'" on a rank-deficient reference -- +# verified by running it on this same data. +# * gLDSC and S-LDSC carry a 1e-8 ridge so an exactly singular design +# returns a value rather than NA. +# ============================================================================= + +test_that("HDL reproduces upstream HDL", { + data(ldEigenExample, ldScoreExample) + reference <- list( + list(h2 = 0.4, n = 1e5, seed = 2, nRef = 20000L, want = 0.405111844), + list(h2 = 0.3, n = 1e4, seed = 5, nRef = 20000L, want = 0.286758612), + list(h2 = 0.6, n = 5e4, seed = 9, nRef = 50000L, want = 0.646809004) + ) + for (g in reference) { + ref <- ldEigenExample + ref@nRef <- g$nRef + z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) + est <- suppressWarnings(pecotmr:::hdlUnivariate(z, g$n, ref)$h2) + expect_equal(est, g$want, tolerance = 1e-6) + } +}) + +test_that("the HDL variance floor matches upstream's exp(-10)", { + # Upstream llfun floors the modelled per-direction variance at exp(-10). + # On a real reference the floor is active for a large share of the + # eigen-directions, and the bstar^2/lamh2 term it feeds dominates the + # likelihood -- a different floor silently moves the optimum. + expect_equal(formals(pecotmr:::.hdlNll)$lim, quote(exp(-10))) +}) + +test_that("LDER reproduces upstream LDER", { + data(ldEigenExample, ldScoreExample) + reference <- list( + list(h2 = 0.4, n = 1e5, seed = 2, want = 0.416906429), + list(h2 = 0.3, n = 1e4, seed = 5, want = 0.289677426), + list(h2 = 0.6, n = 5e4, seed = 9, want = 0.626712459) + ) + for (g in reference) { + z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) + est <- pecotmr:::lderUnivariate(z, g$n, ldEigenExample)$h2 + expect_equal(est, g$want, tolerance = 1e-6) + } +}) + +test_that("gLDSC reproduces upstream gldsc", { + data(ldScoreExample) + reference <- list( + list(h2 = 0.4, n = 5e4, seed = 3, want = 0.407716183), + list(h2 = 0.3, n = 1e4, seed = 5, want = 0.290373743) + ) + for (g in reference) { + z <- .sldscUpstreamZ(ldScoreExample, g$h2, g$n, g$seed) + est <- pecotmr:::gldscUnivariate(z, g$n, ldScoreExample)$h2 + expect_equal(est, g$want, tolerance = 1e-6) + } +}) + + +# =========================================================================== +# Study resolution, genome checking and the chi2 filter fallback +# =========================================================================== + +test_that("an explicit study is used without inspecting the collection", { + expect_equal(pecotmr:::.estimateH2ResolveStudy(NULL, "myStudy"), "myStudy") +}) + +test_that("the genome check reports NA, the build, or refuses a mixture", { + gr <- GenomicRanges::GRanges( + c("chr1", "chr2"), + IRanges::IRanges(c(1L, 2L), width = 1L) + ) + # No build recorded: NA rather than a guess. + expect_true(is.na(pecotmr:::.h2GenomeOfRanges(gr))) + GenomeInfoDb::genome(gr) <- c("hg19", "hg38") + # Mixed builds mean the parts were never comparable. + expect_error( + pecotmr:::.h2GenomeOfRanges(gr), + "names 2 genome build" + ) + GenomeInfoDb::genome(gr) <- "hg38" + expect_equal(pecotmr:::.h2GenomeOfRanges(gr), "hg38") +}) + +test_that("the chi2 filter is abandoned when too few variants survive it", { + # Upstream drops chi2 >= 30, but with fewer than 4 survivors the + # regression has nothing to fit, so the filter is dropped rather than + # returning an estimate from 3 points. + A <- matrix(1, 6L, 1L) + sc <- matrix(1, 6L, 1L) + out <- pecotmr:::.sldscFitUnivariate( + rep(100, 6L), + sc, + rep(1, 6L), + 1000, + A, + 2L + ) + expect_setequal( + names(out), + c("tau", "h2", "estH", "intercept", "coef") + ) + expect_false(is.na(out$h2)) +}) + + +# =========================================================================== +# HDL bound diagnostics and the partitioned chi2 filter +# =========================================================================== + +test_that("HDL warns only when a parameter sits at its UPPER bound", { + # Only upper bounds are diagnostic: an intercept resting at 0 just means + # no confounding and is routine, so a lower bound must not warn. + f <- pecotmr:::.hdlWarnIfAtBound + expect_silent(f(c(0.1, 0.5), c(0, 0), c(1, 2), 1000, 500)) + # At a lower bound: still silent. + expect_silent(f(c(0, 0), c(0, 0), c(1, 2), 1000, 500)) +}) + +test_that("the HDL bound warning names which parameter pinned", { + # The last parameter is the intercept; anything else is heritability. + f <- pecotmr:::.hdlWarnIfAtBound + expect_warning( + f(c(0.1, 2), c(0, 0), c(1, 2), 1000, 500), + "the fitted intercept sits at the top of its range" + ) + expect_warning( + f(c(1, 0.5), c(0, 0), c(1, 2), 1000, 500), + "the fitted heritability sits at the top of its range" + ) +}) + +test_that("the partitioned chi2 filter is abandoned when too few survive", { + # Stratified S-LDSC needs more surviving variants than annotations + 2; + # below that the filter is dropped rather than solving an underdetermined + # system. + A <- matrix(1, 6L, 1L) + sc <- matrix(1, 6L, 2L) + out <- pecotmr:::.sldscFitPartitioned( + rep(1e6, 6L), + sc, + rep(1, 6L), + 1000, + A + ) + expect_setequal( + names(out), + c("tau", "h2", "estH", "intercept", "coef") + ) +}) + +# --------------------------------------------------------------------------- +# Fallbacks and degenerate inputs: each returns a defined answer rather than +# propagating an error out of an estimator. +# --------------------------------------------------------------------------- + +test_that(".rmaMetaFallbackToDL falls back to the closed-form estimator", { + skip_if_not_installed("metafor") + # DL never iterates, so it is a safe landing point when REML/ML fail on + # small or near-homogeneous inputs. + expect_warning( + fit <- pecotmr:::.rmaMetaFallbackToDL( + simpleError("did not converge"), + means = c(0.1, 0.2, 0.15), + ses = c(0.05, 0.06, 0.04), + method = "REML" + ), + "method = 'REML'\\) failed .* falling back to DL" + ) + expect_equal(fit$method, "DL") +}) + +test_that(".h2BaselineMat is NULL when no annotation is baseline tier", { + n <- 5L + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges( + start = as.integer(seq(50, by = 100, length.out = n)), + width = 1L + ) + ) + mat <- matrix(c(rep(1L, n), rep(0L, n)), nrow = n, ncol = 2L) + colnames(mat) <- c("cand_A", "cand_B") + meta <- data.frame( + name = c("cand_A", "cand_B"), + tier = c("candidate", "candidate"), + type = c("binary", "binary"), + stringsAsFactors = FALSE + ) + am <- AnnotationMatrix(mat, gr, meta, genome = "hg19") + # The object has annotations, but none of them are baseline. + expect_equal(ncol(assay(getBaseline(am), "annotations")), 0L) + expect_null(pecotmr:::.h2BaselineMat(am)) + expect_null(pecotmr:::.h2BaselineMat(NULL)) +}) + +test_that(".lderGetRes(twostage = FALSE) returns the free-intercept fit", { + set.seed(4) + m <- 60L + res <- pecotmr:::.lderGetRes( + x = rnorm(m), + lam = abs(rnorm(m, 3, 0.5)), + ldAnnot = matrix(1, nrow = m, ncol = 1L), + N = 1000, + M = 5000, + M_a = 5000, + rough = FALSE, + twostage = FALSE + ) + # One pass, no chi2 outlier filtering, intercept left free. + expect_setequal(names(res), c("h2", "h2a", "tau", "a")) + expect_true(is.finite(res$a)) +}) + +test_that(".lderLocalBlock reports NA for a block too small to fit", { + out <- pecotmr:::.lderLocalBlock( + list(lam = c(1, 2), x = c(0.5, 0.6)), + b = 7L, + N = 1000, + a = 1 + ) + # Fewer than 3 eigenvalues: a slope cannot be identified. + expect_equal(out$blockId, 7L) + expect_true(is.na(out$h2Local)) + 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), + tauBlocks = 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( + CHR = rep("chr22", n), + BP = as.integer(seq(1000, by = 100, length.out = n)), + SNP = str_c("chr22:", seq(1000, by = 100, length.out = n), ":A:G"), + A1 = rep("A", n), + A2 = rep("G", n), + stringsAsFactors = FALSE + ) + mk <- function(blocks) { + LdScore( + snpInfo = snpInfo, + ldScores = matrix(1, nrow = n, ncol = 1L), + ldScoreWeights = rep(1, n), + ldBlocks = blocks, + nRef = 100L, + genome = "hg19", + ldMatrixList = list() + ) + } + # With no precomputed matrices the blocks are intersected with the + # variants; blocks on another chromosome cover nothing. + disjoint <- suppressWarnings( + mk(GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 10000))) + ) + expect_error( + suppressWarnings(pecotmr:::.sldscBlockIndex(disjoint, n)), + "no LD block covers any reference variant" + ) + covering <- mk(GenomicRanges::GRanges("chr22", IRanges::IRanges(1, 10000))) + idx <- pecotmr:::.sldscBlockIndex(covering, n) + expect_equal(unname(lengths(idx)), n) +}) + +test_that(".sldscIrwls derives its own starting weights when none are given", { + set.seed(3) + nv <- 40L + scores <- matrix(abs(rnorm(nv * 2L, 5, 1)), nrow = nv) + y <- 1 + rowSums(scores) * 1e-4 * 500 + rnorm(nv, sd = 0.05) + fit <- pecotmr:::.sldscIrwls( + y = y, + scores = scores, + baseScore = rowSums(scores), + n = 500, + M = 1000, + nIter = 2L, + freeIntercept = FALSE, + intercept = 1, + w0 = NULL + ) + expect_setequal(names(fit), c("coef", "intercept")) + expect_true(all(is.finite(fit$coef))) +}) + +test_that(".sldscLocal clamps a negative LD score to zero", { + out <- pecotmr:::.sldscLocal( + chi2 = c(1.2, 3.4), + baseScore = c(10, -2), + fit = list(tau = c(1e-5)), + M = 1000 + ) + expect_equal(out$variantIdx, 1:2) + expect_equal(out$ldScore, c(10, -2)) + # A negative LD score cannot contribute negative heritability. + expect_equal(out$h2Local, c(1e-4, 0)) +}) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index f120d333..75e63070 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -1161,7 +1161,7 @@ test_that("fitJointGroup(twas): spike-and-slab pi is estimated from an internal pecotmr:::fitJointGroup( g, pipe, - "bayes_c", + "bayesC", list(methodList = list(bayes_c_weights = list())) ) expect_false(is.null(capturedPi)) @@ -1938,7 +1938,7 @@ test_that("fitJointGroup(twas): spike-and-slab pi feeds bayes_b probIn", { pecotmr:::fitJointGroup( g, pipe, - "bayes_b", + "bayesB", list(methodList = list(bayes_b_weights = list())) ) expect_equal(as.numeric(capturedProbIn), 1 - 0.7, tolerance = 1e-8) @@ -2266,3 +2266,427 @@ test_that(".runJointSpecs: region mode without traitId restricts scoped traits t expect_null(res) # empty cell -> NULL expect_equal(captured, c("g1", "g2")) # 871-875 ran }) + + +# =========================================================================== +# Per-row anchors: .traitPosFor() / .fitRegionFor() +# +# traitPos and region are DISTINCT anchors and diverge by input type, but +# nothing exercised either helper. The QtlSumStats traitPos branch was in fact +# unreachable: its guard read names(data) -- a collection's GRangesList +# element names, always empty -- rather than colnames(), so every +# sumstats-derived row silently fell back to the chrUn sentinel. +# =========================================================================== + +.je_mkSsEntry <- function(chr, pos) { + gr <- GenomicRanges::GRanges(chr, IRanges::IRanges(pos, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + variant_id = str_c(chr, ":", pos, ":C:T"), + A1 = rep("T", length(pos)), + A2 = rep("C", length(pos)), + z = rep(1.5, length(pos)), + n = rep(100L, length(pos)) + ) + gr +} + +# A QtlSumStats carrying a traitPos column, which no bundled fixture has. +.je_ssWithTraitPos <- function() { + QtlSumStats( + study = c("S", "S"), + context = c("brain", "brain"), + trait = c("G1", "G2"), + entry = list( + .je_mkSsEntry("chr1", c(100L, 200L)), + .je_mkSsEntry("chr1", c(300L, 400L)) + ), + genome = "hg38", + traitPos = GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(500L, 900L), width = 1L) + ) + ) +} + +test_that("traitPos comes from the QtlSumStats traitPos column", { + ss <- .je_ssWithTraitPos() + g1 <- pecotmr:::.traitPosFor(ss, "brain", "G1") + g2 <- pecotmr:::.traitPosFor(ss, "brain", "G2") + expect_s4_class(g1, "GRanges") + expect_equal(GenomicRanges::start(g1), 500L) + expect_equal(GenomicRanges::start(g2), 900L) + # The anchor is the supplied position, NOT the variant span (100-200). + expect_equal(as.character(GenomicRanges::seqnames(g1)), "chr1") +}) + +test_that("traitPos is NULL when the sumstats cannot supply one", { + ss <- .je_ssWithTraitPos() + expect_null(pecotmr:::.traitPosFor(ss, "brain", "absentTrait")) + expect_null(pecotmr:::.traitPosFor(ss, "absentContext", "G1")) + # A collection with no traitPos column at all. + data(qtlSumStatsExample) + expect_false(is_in("traitPos", colnames(qtlSumStatsExample))) + expect_null(pecotmr:::.traitPosFor( + qtlSumStatsExample, + as.character(qtlSumStatsExample$context)[[1L]], + as.character(qtlSumStatsExample$trait)[[1L]] + )) +}) + +test_that("the fit region of a QtlSumStats row is its variant span", { + # Sumstats carry no cis-window, so the fitted span IS the region -- + # deliberately different from traitPos (500) above. + ss <- .je_ssWithTraitPos() + r <- pecotmr:::.fitRegionFor(ss, "brain", "G1") + expect_s4_class(r, "GRanges") + expect_equal(GenomicRanges::start(r), 100L) + expect_equal(GenomicRanges::end(r), 200L) + expect_null(pecotmr:::.fitRegionFor(ss, "brain", "absentTrait")) +}) + +test_that("the fit region of a QtlDataset row is traitPos +/- the cis window", { + data(qtlDatasetExample) + qd <- qtlDatasetExample + cx <- getContexts(qd)[[1L]] + tr <- rownames(getPhenotypes(qd, contexts = cx))[[1L]] + tp <- pecotmr:::.traitPosFor(qd, cx, tr) + bare <- pecotmr:::.fitRegionFor(qd, cx, tr) + wide <- pecotmr:::.fitRegionFor(qd, cx, tr, cisWindow = 1e5) + # With no window the region collapses onto the trait position. + expect_equal(GenomicRanges::start(bare), GenomicRanges::start(tp)) + # With one it is symmetric about it. + expect_equal( + GenomicRanges::start(wide), + GenomicRanges::start(tp) - 1e5L + ) + expect_equal(GenomicRanges::end(wide), GenomicRanges::end(tp) + 1e5L) +}) + +test_that("the anchors are NULL for a trait the dataset does not carry", { + data(qtlDatasetExample) + qd <- qtlDatasetExample + cx <- getContexts(qd)[[1L]] + expect_null(pecotmr:::.traitPosFor(qd, cx, "absentTrait")) + expect_null(pecotmr:::.traitPosFor(qd, "absentContext", "anything")) + expect_null(pecotmr:::.fitRegionFor(qd, cx, "absentTrait")) +}) + +test_that("the anchors are NULL for an unsupported input class", { + expect_null(pecotmr:::.traitPosFor(42, "a", "b")) + expect_null(pecotmr:::.fitRegionFor(42, "a", "b")) +}) + + +test_that("a sumstats entry with no variants has no fit region", { + # A fitted tuple can still carry zero variants; there is then no span to + # report, which is distinct from the trait being absent. + emptyEntry <- GenomicRanges::GRanges() + S4Vectors::mcols(emptyEntry) <- S4Vectors::DataFrame( + variant_id = character(0), + A1 = character(0), + A2 = character(0), + z = numeric(0), + n = integer(0) + ) + ss <- QtlSumStats( + study = "S", + context = "brain", + trait = "G0", + entry = list(emptyEntry), + genome = "hg38" + ) + expect_null(pecotmr:::.fitRegionFor(ss, "brain", "G0")) +}) + +test_that("slicing a CV result to one condition tolerates absent payloads", { + # predictions / metrics are optional; their absence must not be mistaken + # for a condition with no result. + expect_null(pecotmr:::.sliceTwasCvResultToCondition(NULL, 1L)) + sliced <- pecotmr:::.sliceTwasCvResultToCondition( + list( + samplePartition = "sp", + predictions = NULL, + metrics = NULL, + foldFits = "ff" + ), + 1L + ) + expect_null(sliced$predictions) + expect_null(sliced$metrics) + expect_equal(sliced$samplePartition, "sp") + expect_equal(sliced$foldFits, "ff") +}) + +test_that("the CV slicers keep their result two-dimensional", { + # drop = FALSE throughout: a one-condition slice must stay a matrix so the + # downstream per-method assembly keeps working. + m <- matrix(1:6, 2L, 3L, dimnames = list(c("a", "b"), c("x", "y", "z"))) + col <- pecotmr:::.fmCvSliceCol(m, 2L) + row <- pecotmr:::.fmCvSliceRow(m, 1L) + expect_equal(dim(col), c(2L, 1L)) + expect_equal(dim(row), c(1L, 3L)) + expect_equal(as.vector(col), c(3L, 4L)) + expect_equal(as.vector(row), c(1L, 3L, 5L)) +}) + + +test_that("the anchor vector keeps traitPos and region distinct", { + # Same rows, two anchors that genuinely differ: the supplied trait + # positions (500 / 900) versus the fitted variant spans (100-200 / + # 300-400). Nothing exercised the region kind before. + ss <- .je_ssWithTraitPos() + region <- pecotmr:::.anchorVector( + ss, + c("brain", "brain"), + c("G1", "G2"), + kind = "region" + ) + anchors <- pecotmr:::.anchorVector( + ss, + c("brain", "brain"), + c("G1", "G2"), + kind = "traitPos" + ) + expect_equal(length(region), 2L) + expect_equal(GenomicRanges::start(region), c(100L, 300L)) + expect_equal(GenomicRanges::end(region), c(200L, 400L)) + expect_equal(GenomicRanges::start(anchors), c(500L, 900L)) +}) + + +test_that("a fine-mapping CV handoff tolerates missing performance", { + # prediction and performance are separate slots keyed by token; a fit + # that recorded predictions but no performance still hands over its + # predictions, with metrics NULL rather than erroring. + f <- pecotmr:::.twasFmHandoffCv + expect_null(f(NULL, "susie")) + expect_null(f(list(a = 1), "susie")) + cv <- list( + samplePartition = "SP", + prediction = set_names(list("PRED"), "susie_predicted"), + performance = list() + ) + out <- f(cv, "susie") + expect_equal(out$predictions, "PRED") + expect_null(out$metrics) + expect_equal(out$samplePartition, "SP") + # The token suffix is stripped when matching, so performance is found. + cv$performance <- set_names(list("PERF"), "susie") + expect_equal(f(cv, "susie")$metrics, "PERF") +}) + + +test_that("joint specs accumulate by rbinding distinct tuples", { + # runJointSpecs folds each spec's result into the accumulator; the tuple + # key must stay unique, so two results describing the SAME tuple are + # refused rather than silently duplicating a row. + data(qtlFineMappingExample) + a <- qtlFineMappingExample + b <- qtlFineMappingExample + S4Vectors::mcols(b)$study <- "otherStudy" + out <- pecotmr:::.rbindFineMappingResult(a, b) + expect_equal(length(out), 2L) + expect_setequal( + unique(as.character(out$study)), + c(as.character(a$study)[[1L]], "otherStudy") + ) + expect_error( + pecotmr:::.rbindFineMappingResult(a, a), + "tuple uniqueness" + ) +}) + +test_that("rbinding an empty collection leaves the other unchanged", { + data(qtlFineMappingExample) + expect_equal( + length(pecotmr:::.rbindFineMappingResult( + qtlFineMappingExample, + qtlFineMappingExample[0] + )), + length(qtlFineMappingExample) + ) +}) + +# --------------------------------------------------------------------------- +# Spec accumulation and config defaults: several specs fold into one result by +# collection kind, and an unset ensemble config falls back to its documented +# defaults rather than to NULL. +# --------------------------------------------------------------------------- + +test_that(".runJointSpecs row-binds TWAS results across specs", { + calls <- 0L + local_mocked_bindings( + .jpConfig = function(pipeline) list(ldSketch = NULL), + .runOneJointSpec = function(...) { + calls <<- calls + 1L + str_c("R", calls) + }, + .rbindTwasWeights = function(out, res, ldSketch) str_c(out, "+", res), + .package = "pecotmr" + ) + out <- pecotmr:::.runJointSpecs( + list("s1", "s2", "s3"), NULL, "individual", + NULL, "lasso", NULL, NULL, list() + ) + # The first spec seeds `out`; later ones are bound onto it. + expect_equal(out, "R1+R2+R3") +}) + +test_that(".runJointSpecs row-binds fine-mapping results across specs", { + calls <- 0L + local_mocked_bindings( + .jpConfig = function(pipeline) list(ldSketch = NULL), + .runOneJointSpec = function(...) { + calls <<- calls + 1L + str_c("F", calls) + }, + .rbindFineMappingResult = function(out, res, ldSketch) { + str_c(out, "&", res) + }, + .package = "pecotmr" + ) + # The pipeline class, not the data, picks which rbind is used. + out <- pecotmr:::.runJointSpecs( + list("s1", "s2"), NULL, "individual", + new("FmJointPipeline"), "susie", NULL, NULL, list() + ) + expect_equal(out, "F1&F2") +}) + +test_that(".runJointSpecs skips a spec that produced nothing", { + local_mocked_bindings( + .jpConfig = function(pipeline) list(ldSketch = NULL), + .runOneJointSpec = function(spec, ...) { + if (spec == "s1") NULL else "KEPT" + }, + .rbindTwasWeights = function(out, res, ldSketch) str_c(out, "+", res), + .package = "pecotmr" + ) + # A NULL spec must not seed `out`, or the bind would carry a NULL. + expect_equal( + pecotmr:::.runJointSpecs( + list("s1", "s2"), NULL, "individual", + NULL, "lasso", NULL, NULL, list() + ), + "KEPT" + ) +}) + +test_that(".twasGroupArgs yields no fitted models when the fit is absent", { + local_mocked_bindings( + .jpConfig = function(p) list(), + .jgConditions = function(g) list(study = "s", context = "c", + trait = "t"), + .twasFineMappingFits = function(...) NULL, + .twasCvResultFor = function(...) NULL, + .package = "pecotmr" + ) + out <- pecotmr:::.twasGroupArgs( + "g", + new("TwasJointPipeline"), + list(fineMappingResult = "notNull") + ) + # An empty list, not NULL: downstream indexes it per region. + expect_identical(out$fittedModels, list()) +}) + +test_that(".twasEnsembleLayer falls back to its documented config defaults", { + local_mocked_bindings( + .jgY = function(g) matrix(0, 2L, 1L), + .jgConditions = function(g) data.frame(), + .package = "pecotmr" + ) + # An empty cfg must still resolve r2Cut = 0.01 and solver = "quadprog"; + # with no conditions the layer maps over nothing and returns a list. + out <- pecotmr:::.twasEnsembleLayer("grp", list(), list()) + expect_type(out, "list") + expect_length(out, 0L) + explicit <- pecotmr:::.twasEnsembleLayer( + "grp", + list(), + list( + ensembleR2Threshold = 0.2, + ensembleSolver = "nnls", + ensembleAlpha = 0.5 + ) + ) + expect_length(explicit, 0L) +}) + +test_that(".jointTwasCv prefers per-call CV settings over the config", { + seen <- NULL + local_mocked_bindings( + .twasFmHandoffCv = function(...) NULL, + .jointTwasLeakageWarn = function(...) invisible(NULL), + twasWeightsCv = function(X, Y, fold, samplePartitions, weightMethods, + retainFits, maxNumVariants, numThreads, + data_driven_priorMatricesCv, verbose, seed) { + seen <<- list(sp = samplePartitions, mcv = maxNumVariants) + "CV" + }, + .jointTwasCvResult = function(cv, token) cv, + .package = "pecotmr" + ) + args <- list( + fineMappingCv = NULL, + samplePartition = "ARGS_SP", + dataDrivenPriorMatricesCv = NULL + ) + cfg <- list( + cvFolds = 5L, samplePartition = "CFG_SP", maxCvVariants = 77L, + cvThreads = 1, seed = 1L, verbose = 0 + ) + pecotmr:::.jointTwasCv( + NULL, NULL, "lasso", NULL, c(1, 2), args, cfg, "lasso" + ) + expect_equal(seen$sp, "ARGS_SP") + expect_equal(seen$mcv, 77L) + # With no per-call partition the config supplies it, and a non-positive + # maxCvVariants means "no cap" rather than "cap at zero". + argsBare <- args + argsBare$samplePartition <- NULL + cfgUncapped <- cfg + cfgUncapped$maxCvVariants <- 0 + pecotmr:::.jointTwasCv( + NULL, NULL, "lasso", NULL, c(1, 2), argsBare, cfgUncapped, "lasso" + ) + expect_equal(seen$sp, "CFG_SP") + expect_equal(seen$mcv, Inf) +}) + +test_that(".enumUnivariateIndividual reads a region instead of a cis window", { + seen <- NULL + phenotypes <- matrix( + 0, + nrow = 1L, + ncol = 2L, + dimnames = list("t1", c("s1", "s2")) + ) + local_mocked_bindings( + getStudy = function(data) "S1", + getPhenotypes = function(data, contexts) phenotypes, + .fmResidPheno = function(data, contexts, traitId, naAction) { + matrix(1, 2L, 1L, dimnames = list(c("s1", "s2"), "t1")) + }, + .fmResidGeno = function(data, contexts, traitId = NULL, + cisWindow = NULL, region = NULL) { + seen <<- list(traitId = traitId, cisWindow = cisWindow, + region = region) + matrix(0, 2L, 2L, dimnames = list(c("s1", "s2"), c("v1", "v2"))) + }, + .package = "pecotmr" + ) + scope <- list( + studies = "S1", + contexts = list(S1 = "cA"), + traits = list(S1 = "t1") + ) + pecotmr:::.enumUnivariateIndividual( + NULL, scope, list(region = "chr1:1-1000") + ) + # An explicit region replaces the trait-anchored cis window entirely -- + # neither traitId nor cisWindow is passed down. + expect_equal(seen$region, "chr1:1-1000") + expect_null(seen$cisWindow) + expect_null(seen$traitId) +}) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index e98ee421..feeb07cc 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -1670,7 +1670,7 @@ test_that(".buildJointSumstatZMatrix: a mismatched SNP order across entries erro ) calls <- 0L local_mocked_bindings( - getSumstatDf = function(x, study, context, trait, require, ...) { + getSumStatsDf = function(x, study, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") diff --git a/tests/testthat/test_ld.R b/tests/testthat/test_ld.R index 376aeb48..5490c89b 100644 --- a/tests/testthat/test_ld.R +++ b/tests/testthat/test_ld.R @@ -1857,7 +1857,7 @@ test_that("dropCollinearColumns variance strategy removes lowest-variance column expect_equal(ncol(result), 3L) }) -test_that("dropCollinearColumns response_correlation strategy works", { +test_that("dropCollinearColumns responseCorrelation strategy works", { set.seed(42) X <- matrix(rnorm(100 * 3), 100, 3) colnames(X) <- c("a", "b", "c") @@ -1865,7 +1865,7 @@ test_that("dropCollinearColumns response_correlation strategy works", { result <- pecotmr:::dropCollinearColumns( X, c("a", "b", "c"), - strategy = "response_correlation", + strategy = "responseCorrelation", response = y ) # Should keep "a" (highest |cor| with response) and remove one of b/c @@ -1873,14 +1873,14 @@ test_that("dropCollinearColumns response_correlation strategy works", { expect_equal(ncol(result), 2L) }) -test_that("dropCollinearColumns response_correlation errors without response", { +test_that("dropCollinearColumns responseCorrelation errors without response", { X <- matrix(1:12, 4, 3) colnames(X) <- c("a", "b", "c") expect_error( pecotmr:::dropCollinearColumns( X, c("a", "b"), - strategy = "response_correlation" + strategy = "responseCorrelation" ), "response must be supplied" ) @@ -1910,7 +1910,7 @@ test_that("enforceDesignFullRank variance strategy produces full rank", { expect_true(ncol(result) < ncol(X)) }) -test_that("enforceDesignFullRank response_correlation strategy works", { +test_that("enforceDesignFullRank responseCorrelation strategy works", { set.seed(42) X <- matrix(rnorm(100 * 4), 100, 4) X[, 4] <- X[, 1] + X[, 2] @@ -1920,7 +1920,7 @@ test_that("enforceDesignFullRank response_correlation strategy works", { result <- enforceDesignFullRank( X, C, - strategy = "response_correlation", + strategy = "responseCorrelation", response = y ) full_design <- cbind(1, result, C) @@ -2082,299 +2082,8 @@ test_that("loadLdMatrix dedup removes duplicated variants from result", { }) -context("ldLoader") - -# =========================================================================== -# ldLoader: input validation -# =========================================================================== - -test_that("ldLoader errors when no source is provided", { - expect_error(ldLoader(), "Provide exactly one") -}) - -test_that("ldLoader errors when multiple sources are provided", { - R <- list(matrix(1, 2, 2)) - X <- list(matrix(1, 3, 2)) - expect_error(ldLoader(rList = R, xList = X), "Provide exactly one") -}) - -# =========================================================================== -# ldLoader: R_list branch -# =========================================================================== - -test_that("ldLoader with rList returns an ldLoaderSpec", { - R <- list(matrix(c(1, 0.5, 0.5, 1), 2, 2)) - spec <- ldLoader(rList = R) - expect_s3_class(spec, "ldLoaderSpec") -}) - -test_that("ldLoader R_list returns correct matrix", { - R1 <- matrix(c(1, 0.3, 0.3, 1), 2, 2) - R2 <- matrix(c(1, 0.8, 0.8, 1), 2, 2) - loader <- ldLoader(rList = list(R1, R2)) - expect_equal(loadLdBlock(loader, 1), R1) - expect_equal(loadLdBlock(loader, 2), R2) -}) - -test_that("ldLoader R_list with max_variants downsamples", { - set.seed(42) - R <- matrix(0.1, 10, 10) - diag(R) <- 1 - loader <- ldLoader(rList = list(R), maxVariants = 5) - result <- loadLdBlock(loader, 1) - expect_equal(nrow(result), 5) - expect_equal(ncol(result), 5) -}) - -test_that("ldLoader R_list without max_variants returns full matrix", { - R <- matrix(0.1, 10, 10) - diag(R) <- 1 - loader <- ldLoader(rList = list(R)) - result <- loadLdBlock(loader, 1) - expect_equal(nrow(result), 10) -}) - -test_that("ldLoader R_list max_variants larger than matrix returns full matrix", { - R <- matrix(0.1, 3, 3) - diag(R) <- 1 - loader <- ldLoader(rList = list(R), maxVariants = 100) - result <- loadLdBlock(loader, 1) - expect_equal(nrow(result), 3) -}) - -# =========================================================================== -# ldLoader: X_list branch -# =========================================================================== - -test_that("ldLoader with xList returns an ldLoaderSpec", { - X <- list(matrix(rnorm(30), 10, 3)) - spec <- ldLoader(xList = X) - expect_s3_class(spec, "ldLoaderSpec") -}) - -test_that("ldLoader X_list returns correct matrix", { - X1 <- matrix(1:12, 4, 3) - X2 <- matrix(1:8, 4, 2) - loader <- ldLoader(xList = list(X1, X2)) - expect_equal(loadLdBlock(loader, 1), X1) - expect_equal(loadLdBlock(loader, 2), X2) -}) - -test_that("ldLoader X_list with max_variants downsamples columns", { - set.seed(42) - X <- matrix(rnorm(50), 10, 5) - loader <- ldLoader(xList = list(X), maxVariants = 3) - result <- loadLdBlock(loader, 1) - expect_equal(nrow(result), 10) - expect_equal(ncol(result), 3) -}) - -test_that("ldLoader X_list max_variants larger than ncol returns full matrix", { - X <- matrix(rnorm(12), 4, 3) - loader <- ldLoader(xList = list(X), maxVariants = 100) - result <- loadLdBlock(loader, 1) - expect_equal(ncol(result), 3) -}) - -# =========================================================================== -# ldLoader: ld_meta_path branch validation -# =========================================================================== - -test_that("ldLoader with ld_meta_path but no regions errors", { - expect_error( - ldLoader(ldMetaPath = "/some/path"), - "regions.*required" - ) -}) - -# =========================================================================== -# ldLoader: ldInfo branch validation -# =========================================================================== - -test_that("ldLoader with ldInfo errors when not a data.frame", { - expect_error( - ldLoader(ldInfo = "not_a_df"), - "ldInfo must be a data.frame" - ) -}) - -test_that("ldLoader with ldInfo errors when missing LD_file column", { - expect_error( - ldLoader(ldInfo = data.frame(col1 = "a")), - "ldInfo must be a data.frame with column 'LD_file'" - ) -}) - -# =========================================================================== -# ldLoader: ldInfo branch with real genotype fixtures -# =========================================================================== - test_data_dir <- test_path("test_data") -test_that("ldLoader ldInfo loads LD from PLINK2 files", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(test_data_dir, "test_variants") - loader <- ldLoader(ldInfo = data.frame(LD_file = plink_prefix)) - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_equal(nrow(mat), 349L) - expect_equal(ncol(mat), 349L) - expect_true(isSymmetric(mat)) - expect_true(all(abs(diag(mat) - 1) < 1e-10)) -}) - -test_that("ldLoader ldInfo loads LD from VCF file", { - skip_if_not_installed("VariantAnnotation") - vcf_path <- file.path(test_data_dir, "test_variants.vcf.gz") - loader <- ldLoader(ldInfo = data.frame(LD_file = vcf_path)) - mat <- suppressWarnings(loadLdBlock(loader, 1)) - expect_true(is.matrix(mat)) - expect_equal(nrow(mat), 349L) - expect_true(isSymmetric(mat)) -}) - -test_that("ldLoader ldInfo loads LD from GDS file", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - gds_path <- file.path(test_data_dir, "test_variants.gds") - loader <- ldLoader(ldInfo = data.frame(LD_file = gds_path)) - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_equal(nrow(mat), 349L) - expect_true(isSymmetric(mat)) -}) - -test_that("ldLoader ldInfo loads LD from PLINK1 files", { - skip_if_not_installed("snpStats") - plink1_prefix <- file.path(test_data_dir, "protocol_example.genotype") - loader <- ldLoader(ldInfo = data.frame(LD_file = plink1_prefix)) - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_true(isSymmetric(mat)) -}) - -test_that("ldLoader ldInfo loads pre-computed .cor.xz blocks", { - ld_file <- file.path( - test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - bim_file <- file.path( - test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ) - - # Mock processLdMatrix to wrap its result in an LdData S4 object, - # since extract_ld_matrix now requires an LdData. - real_process <- pecotmr:::processLdMatrix - local_mocked_bindings( - processLdMatrix = function(LD_file_path, snp_file_path = NULL) { - result <- real_process(LD_file_path, snp_file_path) - mat <- result$ldMatrix - variant_ids <- result$ldVariants$variants - ref_panel <- pecotmr:::parseVariantId(variant_ids) - ref_panel$variant_id <- variant_ids - variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) - bm <- data.frame( - blockId = 1L, - chrom = as.character(ref_panel$chrom[1]), - blockStart = min(ref_panel$pos), - blockEnd = max(ref_panel$pos), - size = length(variant_ids), - startIdx = 1L, - endIdx = length(variant_ids), - stringsAsFactors = FALSE - ) - LdData( - correlation = mat, - variants = variants_gr, - blockMetadata = bm - ) - }, - .package = "pecotmr" - ) - - loader <- ldLoader( - ldInfo = data.frame(LD_file = ld_file, SNP_file = bim_file) - ) - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_true(isSymmetric(mat)) - expect_true(nrow(mat) > 0) -}) - -test_that("ldLoader ldInfo with max_variants subsamples", { - skip_if_not_installed("pgenlibr") - plink_prefix <- file.path(test_data_dir, "test_variants") - set.seed(42) - loader <- ldLoader( - ldInfo = data.frame(LD_file = plink_prefix), - maxVariants = 20 - ) - mat <- loadLdBlock(loader, 1) - expect_equal(nrow(mat), 20L) - expect_equal(ncol(mat), 20L) -}) - -test_that("ldLoader ldInfo returns consistent LD across formats", { - skip_if_not_installed("pgenlibr") - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - plink_prefix <- file.path(test_data_dir, "test_variants") - gds_path <- file.path(test_data_dir, "test_variants.gds") - loader_plink <- ldLoader(ldInfo = data.frame(LD_file = plink_prefix)) - loader_gds <- ldLoader(ldInfo = data.frame(LD_file = gds_path)) - mat_plink <- loadLdBlock(loader_plink, 1) - mat_gds <- loadLdBlock(loader_gds, 1) - expect_equal(dim(mat_plink), dim(mat_gds)) -}) - -# =========================================================================== -# ldLoader: ld_meta_path branch with real genotype fixtures -# =========================================================================== - -test_that("ldLoader ld_meta_path loads LD from PLINK2 metadata", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path(test_data_dir, "ld_meta_plink2_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines( - paste("chrom", "start", "end", "path", sep = "\t"), - meta_file - ) - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - region <- "chr21:17513228-17592874" - loader <- ldLoader(ldMetaPath = meta_file, regions = region) - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_equal(nrow(mat), 349L) - expect_equal(ncol(mat), 349L) -}) - -test_that("ldLoader ld_meta_path loads LD from VCF metadata", { - skip_if_not_installed("VariantAnnotation") - meta_file <- file.path(test_data_dir, "ld_meta_vcf_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines( - paste("chrom", "start", "end", "path", sep = "\t"), - meta_file - ) - cat( - paste("21", "0", "0", "test_variants.vcf.gz", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - region <- "chr21:17513228-17592874" - loader <- ldLoader(ldMetaPath = meta_file, regions = region) - mat <- suppressWarnings(loadLdBlock(loader, 1)) - expect_true(is.matrix(mat)) - expect_equal(nrow(mat), 349L) -}) - library(testthat) @@ -2534,7 +2243,7 @@ test_that("dropCollinearColumns correlation strategy with 3+ cols removes highes expect_equal(ncol(result), 3) }) -test_that("dropCollinearColumns response_correlation strategy removes lowest |cor| with response", { +test_that("dropCollinearColumns responseCorrelation strategy removes lowest |cor| with response", { set.seed(42) n <- 50 X <- matrix(rnorm(n * 3), nrow = n, ncol = 3) @@ -2543,21 +2252,21 @@ test_that("dropCollinearColumns response_correlation strategy removes lowest |co result <- pecotmr:::dropCollinearColumns( X, problematicCols = c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G"), - strategy = "response_correlation", + strategy = "responseCorrelation", response = response ) expect_equal(ncol(result), 2) expect_true("chr1:100:A:G" %in% colnames(result)) }) -test_that("dropCollinearColumns errors on response_correlation without response", { +test_that("dropCollinearColumns errors on responseCorrelation without response", { X <- matrix(rnorm(60), 20, 3) colnames(X) <- c("chr1:100:A:G", "chr1:200:A:G", "chr1:300:A:G") expect_error( pecotmr:::dropCollinearColumns( X, problematicCols = c("chr1:100:A:G", "chr1:200:A:G"), - strategy = "response_correlation" + strategy = "responseCorrelation" ), "response" ) @@ -2705,9 +2414,6 @@ test_that("ldClumpByScore returns indices on real data", { expect_true(length(keep) < p) }) -# =========================================================================== -# Tests migrated from test_twasSketch.R (loadLdSketch / standardizeGenotypeHwe) -# =========================================================================== test_that("standardize_genotype_hwe: centers by 2p and scales by sqrt(2p(1-p))", { set.seed(42) @@ -2724,137 +2430,6 @@ test_that("standardize_genotype_hwe: centers by 2p and scales by sqrt(2p(1-p))", }) -test_that("loadLdSketch: returns LdData with raw genotypes and metadata", { - set.seed(55) - n <- 30 - p <- 12 - variant_ids <- paste0("chr1:", seq(1000, by = 100, length.out = p), ":A:G") - - # Create a mock genotype matrix - af_true <- runif(p, 0.1, 0.9) - X <- matrix(rbinom(n * p, 2, rep(af_true, each = n)), nrow = n, ncol = p) - - # Build mock ref_panel - ref_panel <- data.frame( - chrom = 1L, - pos = seq(1000, by = 100, length.out = p), - A2 = "A", - A1 = "G", - variant_id = variant_ids, - allele_freq = colMeans(X) / 2, - stringsAsFactors = FALSE - ) - - variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) - blockMetadata <- S4Vectors::DataFrame( - region = "chr1:1000-2100", - start = 1000L, - end = 2100L, - chrom = "chr1" - ) - # Store genotype matrix directly in genotype_handle (matching loadLdSketch output) - mock_ld_data <- new( - "LdData", - variants_gr, - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - blockMetadata = blockMetadata - ) - - local_mocked_bindings( - loadLdMatrix = function( - ld_meta_file_path, - region, - return_genotype = FALSE, - n_sample = NULL, - ... - ) { - mock_ld_data - }, - .package = "pecotmr" - ) - - result <- pecotmr::loadLdSketch("fake_path.tsv", "chr1:1000-2100") - - # Check structure -- returns an LdData S4 object - expect_true(is(result, "LdData")) - result_X <- getGenotypes(result) - result_ref <- getRefPanel(result) - result_ids <- getVariantIds(result) - expect_equal(nrow(result_X), n) - expect_equal(ncol(result_X), p) - expect_equal(length(result_ids), p) - - # Raw genotype matrix is returned unchanged - expect_equal(result_X, X) -}) - - -test_that("loadLdSketch: removes monomorphic variants", { - set.seed(66) - n <- 20 - p <- 5 - variant_ids <- paste0("chr1:", 1:p, ":A:G") - - # Make column 3 monomorphic (all 0) - X <- matrix(rbinom(n * p, 2, 0.3), nrow = n, ncol = p) - X[, 3] <- 0 # monomorphic - - ref_panel <- data.frame( - chrom = 1L, - pos = 1:p, - A2 = "A", - A1 = "G", - variant_id = variant_ids, - allele_freq = colMeans(X) / 2, - stringsAsFactors = FALSE - ) - - variants_gr <- pecotmr:::.refPanelToGranges(ref_panel) - blockMetadata <- S4Vectors::DataFrame( - region = "chr1:1-5", - start = 1L, - end = 5L, - chrom = "chr1" - ) - # Store genotype matrix directly in genotype_handle - mock_ld_data <- new( - "LdData", - variants_gr, - correlation = NULL, - genotypeHandle = X, - snpIdx = NULL, - blockMetadata = blockMetadata - ) - - local_mocked_bindings( - loadLdMatrix = function( - ld_meta_file_path, - region, - return_genotype = FALSE, - n_sample = NULL, - ... - ) { - mock_ld_data - }, - .package = "pecotmr" - ) - - result <- pecotmr::loadLdSketch("fake_path.tsv", "chr1:1-5") - - # Returns LdData with monomorphic variant removed - expect_true(is(result, "LdData")) - result_ids <- getVariantIds(result) - result_ref <- getRefPanel(result) - result_X <- getGenotypes(result) - expect_equal(length(result_ids), p - 1) - expect_false(variant_ids[3] %in% result_ids) - expect_equal(nrow(result_ref), p - 1) - expect_equal(ncol(result_X), p - 1) -}) - - test_that("SVD from raw sketch matches direct computation", { set.seed(77) n <- 25 @@ -3658,6 +3233,45 @@ test_that(".ldFromSketch returns a symmetric unit-diagonal LD matrix", { expect_equal(R, t(R), tolerance = 1e-12) }) +test_that(".ldFromSketch negates LD for a variant the panel spells flipped", { + # The panel carries A/G; asking for the same variant as G/A is the same + # variant read off the other allele, so every correlation it takes part in + # changes sign while the diagonal stays 1. Before the sign was applied the + # two calls returned an identical matrix, which silently mis-signed the LD + # against a caller whose alleles were oriented the other way. + h <- .lds_makeHandle() + local_mocked_bindings( + extractBlockGenotypes = .lds_mockExtractor(), + .package = "pecotmr" + ) + same <- c("chr1:200:A:G", "chr1:400:A:G", "chr1:500:A:G") + flipped <- c("chr1:200:G:A", "chr1:400:A:G", "chr1:500:A:G") + rSame <- pecotmr:::.ldFromSketch(h, same) + rFlip <- pecotmr:::.ldFromSketch(h, flipped) + sgn <- c(-1, 1, 1) + expect_equal( + unname(rFlip), + unname(rSame) * outer(sgn, sgn), + tolerance = 1e-12 + ) + expect_equal(unname(diag(rFlip)), rep(1, 3), tolerance = 1e-12) + expect_equal(dimnames(rFlip), list(flipped, flipped)) +}) + +test_that(".ldFromSketch leaves LD untouched when every allele agrees", { + h <- .lds_makeHandle() + local_mocked_bindings( + extractBlockGenotypes = .lds_mockExtractor(), + .package = "pecotmr" + ) + ids <- c("chr1:200:A:G", "chr1:400:A:G") + expect_equal( + pecotmr:::.ldFromSketch(h, ids), + pecotmr:::.ldFromSketch(h, ids), + tolerance = 1e-12 + ) +}) + test_that(".ldFromSketch errors on a variant the panel does not carry", { h <- .lds_makeHandle() expect_error( @@ -3735,28 +3349,6 @@ test_that(".requireMatchingLdSketches tolerates a chr-prefix-only difference", { ) }) -# ============================================================================= -# Additional coverage: loadLdSketch non-LdData guard -# ============================================================================= - -test_that("loadLdSketch errors when loadLdMatrix does not return an LdData", { - local_mocked_bindings( - loadLdMatrix = function( - ldMetaFilePath, - region, - returnGenotype = FALSE, - nSample = NULL, - ... - ) { - list() - }, - .package = "pecotmr" - ) - expect_error( - pecotmr::loadLdSketch("fake_path.tsv", "chr1:1-100"), - "must return an LdData" - ) -}) # ============================================================================= # Additional coverage: loadLdFromBlocks empty-block handling @@ -4092,7 +3684,7 @@ test_that("dropCollinearColumns prints verbose messages for each strategy", { pecotmr:::dropCollinearColumns( X, c("a", "b", "c"), - strategy = "response_correlation", + strategy = "responseCorrelation", response = y, verbose = TRUE ), @@ -4238,118 +3830,26 @@ test_that("extractLdMatrix returns the genotype matrix when wantGenotype=TRUE", expect_equal(result, X) }) + # ============================================================================= -# Additional coverage: ldLoader region-mode subsample/scale + ldInfo auto-detect +# Additional coverage: computeLd alternative backends + guard rails # ============================================================================= -test_that("ldLoader region mode subsamples and scales genotype matrices", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path(test_data_dir, "ld_meta_region_geno_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) +test_that("computeLd snprelate backend returns a valid correlation matrix", { + skip_if_not_installed("SNPRelate") + skip_if_not_installed("gdsfmt") set.seed(1) - loader <- ldLoader( - ldMetaPath = meta_file, - regions = geno_region_all, - returnGenotype = TRUE, - maxVariants = 20 - ) - mat <- loadLdBlock(loader, 1) - expect_equal(ncol(mat), 20L) - expect_equal(nrow(mat), 100L) # samples - expect_true(all(is.finite(mat))) # scaled, NAs replaced with 0 -}) - -test_that("ldLoader region mode subsamples a correlation matrix", { - skip_if_not_installed("pgenlibr") - meta_file <- file.path(test_data_dir, "ld_meta_region_corr_tmp.tsv") - on.exit(unlink(meta_file), add = TRUE) - writeLines(paste("chrom", "start", "end", "path", sep = "\t"), meta_file) - cat( - paste("21", "0", "0", "test_variants", sep = "\t"), - "\n", - file = meta_file, - append = TRUE - ) - set.seed(2) - loader <- ldLoader( - ldMetaPath = meta_file, - regions = geno_region_all, - returnGenotype = FALSE, - maxVariants = 15 - ) - mat <- loadLdBlock(loader, 1) - expect_equal(dim(mat), c(15L, 15L)) -}) - -test_that("ldLoader ldInfo auto-detects companion file when SNP_file is absent", { - ld_file <- file.path( - test_data_dir, - "LD_block_1.chr1_1000_1200.float16.txt.xz" - ) - bim_file <- file.path( - test_data_dir, - "LD_block_1.chr1_1000_1200.float16.bim" - ) - real_process <- pecotmr:::processLdMatrix - local_mocked_bindings( - processLdMatrix = function(LD_file_path, snp_file_path = NULL) { - # In the SNP_file-absent branch, snp_file_path is NULL (auto-detect). - result <- real_process(LD_file_path, bim_file) - variant_ids <- result$ldVariants$variants - ref <- pecotmr:::parseVariantId(variant_ids) - ref$variant_id <- variant_ids - gr <- pecotmr:::.refPanelToGranges(ref) - bm <- data.frame( - blockId = 1L, - chrom = as.character(ref$chrom[1]), - blockStart = min(ref$pos), - blockEnd = max(ref$pos), - size = length(variant_ids), - startIdx = 1L, - endIdx = length(variant_ids), - stringsAsFactors = FALSE - ) - LdData( - correlation = result$ldMatrix, - variants = gr, - blockMetadata = bm - ) - }, - .package = "pecotmr" - ) - loader <- ldLoader(ldInfo = data.frame(LD_file = ld_file)) # no SNP_file column - mat <- loadLdBlock(loader, 1) - expect_true(is.matrix(mat)) - expect_true(isSymmetric(mat)) - expect_true(nrow(mat) > 0) -}) - -# ============================================================================= -# Additional coverage: computeLd alternative backends + guard rails -# ============================================================================= - -test_that("computeLd snprelate backend returns a valid correlation matrix", { - skip_if_not_installed("SNPRelate") - skip_if_not_installed("gdsfmt") - set.seed(1) - X <- matrix(rbinom(100 * 5, 2, 0.3), 100, 5) - colnames(X) <- paste0("rs", 1:5) - R <- suppressMessages(computeLd( - X, - method = "sample", - backend = "snprelate" - )) - expect_equal(dim(R), c(5L, 5L)) - expect_equal(unname(diag(R)), rep(1, 5)) - expect_true(all(is.finite(R))) - expect_equal(colnames(R), colnames(X)) + X <- matrix(rbinom(100 * 5, 2, 0.3), 100, 5) + colnames(X) <- paste0("rs", 1:5) + R <- suppressMessages(computeLd( + X, + method = "sample", + backend = "snprelate" + )) + expect_equal(dim(R), c(5L, 5L)) + expect_equal(unname(diag(R)), rep(1, 5)) + expect_true(all(is.finite(R))) + expect_equal(colnames(R), colnames(X)) }) test_that("computeLd snpstats backend returns a valid correlation matrix", { @@ -4637,3 +4137,817 @@ test_that(".panelAfreqPrefixes reads only the chromosomes the panel spans", { sharded@snpInfo$CHR <- rep("22", nrow(getSnpInfo(handle))) expect_identical(.panelAfreqPrefixes(sharded), getPath(handle)) }) + + +# ============================================================================= +# loadLdMatrix: coordinate-free sources and per-block options +# +# These cover what ldLoader() / loadLdBlock() / loadLdSketch() used to do, +# now folded into the single loader. Every source returns an LdData, which is +# the point of the consolidation -- callers no longer branch on what they +# loaded from. +# ============================================================================= + +test_that("loadLdMatrix requires exactly one addressing mode", { + R <- matrix(c(1, 0.5, 0.5, 1), 2, 2) + expect_error(loadLdMatrix(R), "either `region` or `block`") + expect_error( + loadLdMatrix(R, region = "chr1:1-2", block = 1), + "not both" + ) + # A coordinate-free source cannot be addressed by region. + expect_error(loadLdMatrix(R, region = "chr1:1-2"), "addressed with `block`") +}) + +test_that("loadLdMatrix loads an in-memory correlation matrix by block", { + R1 <- matrix(c(1, 0.3, 0.3, 1), 2, 2) + R2 <- matrix(c(1, 0.8, 0.8, 1), 2, 2) + expect_equal(unname(getCorrelation(loadLdMatrix(R1, block = 1))), R1) + expect_equal( + unname(getCorrelation(loadLdMatrix(list(R1, R2), block = 2))), + R2 + ) +}) + +test_that("loadLdMatrix treats a tall matrix as genotypes", { + X <- matrix(rnorm(40), 10, 4) + ld <- loadLdMatrix(X, block = 1) + expect_true(hasGenotypes(ld)) + expect_equal(length(ld), 4L) +}) + +test_that("loadLdMatrix subsamples oversized blocks reproducibly", { + R <- matrix(0.1, 10, 10) + diag(R) <- 1 + small <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) + expect_equal(length(small), 5L) + expect_equal(dim(getCorrelation(small)), c(5L, 5L)) + # Same seed, same draw. + again <- loadLdMatrix(R, block = 1, maxVariants = 5, seed = 42) + expect_equal(getVariantIds(small), getVariantIds(again)) + # A cap above the block size is a no-op. + expect_equal(length(loadLdMatrix(R, block = 1, maxVariants = 100)), 10L) +}) + +test_that("loadLdMatrix reads an ldInfo table by block", { + skip_if_not_installed("pgenlibr") + ldInfo <- data.frame( + LD_file = file.path(test_path("test_data"), "test_variants") + ) + ld <- loadLdMatrix(ldInfo, block = 1) + expect_s4_class(ld, "LdData") + expect_equal(length(ld), 349L) +}) + +test_that("loadLdMatrix validates an ldInfo table", { + expect_error( + loadLdMatrix(data.frame(col1 = "a"), block = 1), + "needs an `LD_file` column" + ) +}) + +test_that("loadLdMatrix takes a vector of regions", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + region <- "chr22:10000000-19000000" + many <- loadLdMatrix(meta, region = c(region, region)) + expect_type(many, "list") + expect_length(many, 2L) + expect_s4_class(many[[1]], "LdData") + expect_equal(length(many[[1]]), length(many[[2]])) +}) + +test_that("loadLdMatrix can materialize genotypes onto the object", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + region <- "chr22:10000000-19000000" + lazy <- loadLdMatrix(meta, region = region, returnGenotype = TRUE) + eager <- loadLdMatrix( + meta, + region = region, + returnGenotype = TRUE, + materializeGenotypes = TRUE + ) + # Same data; the difference is whether later access re-reads the file. + expect_s4_class(getGenotypeHandle(lazy), "GenotypeHandle") + expect_true(is.matrix(getGenotypeHandle(eager))) + expect_equal(getGenotypes(lazy), getGenotypes(eager)) +}) + +test_that("loadLdMatrix can drop monomorphic variants", { + meta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" + ) + region <- "chr22:10000000-19000000" + full <- loadLdMatrix(meta, region = region, returnGenotype = TRUE) + kept <- loadLdMatrix( + meta, + region = region, + returnGenotype = TRUE, + dropMonomorphic = TRUE + ) + # This panel has no monomorphic variants, so the filter is a no-op here; + # what matters is that it does not drop polymorphic ones. + expect_lte(length(kept), length(full)) + af <- getRefPanel(kept)$allele_freq + expect_true(all(af > 0 & af < 1)) +}) + + +# ============================================================================= +# One failure mode for a missing or invalid LD sketch +# +# Panel access happens through several routes: the shared `.ldFromSketch()`, +# ctwas's whole-panel assembler, RAiSS's coordinate window, and the bare +# accessors. They used to disagree on what a bad sketch looked like -- the +# shared path said so plainly while the others surfaced "unable to find an +# inherited method for 'getSnpInfo'" from whichever accessor touched it +# first. The guard now sits at `.ldSketchRanges()` / `.ldSketchDosage()`, the +# two primitives everything funnels through. +# ============================================================================= + +test_that("every panel access route rejects a NULL sketch the same way", { + df <- data.frame( + chrom = "chr22", + pos = 1:3, + SNP = paste0("chr22:", 1:3, ":A:G") + ) + routes <- list( + shared = function() { + pecotmr:::.ldFromSketch(NULL, "chr22:1:A:G", label = "demo") + }, + ctwas = function() pecotmr:::.ctwasComputeFullPanelLd(NULL), + raiss = function() pecotmr:::.qcRaissWindowIdx(df, NULL, 0L), + matchIds = function() pecotmr:::.ldSketchMatchIds(NULL), + dosage = function() pecotmr:::.ldSketchDosage(NULL, 1L), + ranges = function() pecotmr:::.ldSketchRanges(NULL) + ) + for (nm in names(routes)) { + expect_error(routes[[nm]](), "carries no ldSketch", info = nm) + } +}) + +test_that("a non-panel sketch is rejected by every route", { + expect_error( + pecotmr:::.ldSketchRanges("not a panel"), + "must be a genotype panel" + ) + expect_error( + pecotmr:::.ctwasComputeFullPanelLd("not a panel"), + "must be a genotype panel" + ) + expect_error( + pecotmr:::.ldSketchDosage("not a panel", 1L), + "must be a genotype panel" + ) +}) + +test_that("callers that validate first keep their own label", { + # The generic guard must not mask a caller's more specific message. + shared <- tryCatch( + pecotmr:::.ldFromSketch(NULL, "x", label = "fineMappingPipeline"), + error = conditionMessage + ) + expect_match(shared, "^fineMappingPipeline:") + ctwas <- tryCatch( + pecotmr:::.ctwasComputeFullPanelLd(NULL), + error = conditionMessage + ) + expect_match(ctwas, "^ctwasPipeline:") +}) + +test_that("panel identity uses the allele-repaired ids for comparison", { + # `.ldSketchMatchIds()` repairs an id whose allele fields are tags rather + # than DNA, filling them from the panel's A1/A2 mcols; that repaired form + # is what every comparison against sumstats or weights uses. + repaired <- pecotmr:::.repairVariantIds( + c("chr1:100:R:V", "chr1:200:R:V"), + A2 = c("A", "C"), + A1 = c("G", "T") + ) + expect_equal(repaired, c("chr1:100:A:G", "chr1:200:C:T")) + + # An id that already carries DNA alleles is left alone. + dna <- c("chr1:100:A:G") + expect_equal(pecotmr:::.repairVariantIds(dna, A2 = "C", A1 = "T"), dna) + + # And an rsID panel passes through unchanged -- `.ldFromSketchMatch()` + # falls back to exact id matching for those, so rewriting them would + # break the match rather than fix it. + panel <- readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) + expect_equal( + pecotmr:::.ldSketchMatchIds(panel), + pecotmr:::.ldSketchVariantIds(panel) + ) +}) + + +# =========================================================================== +# Sketch accessors and per-variant panel statistics +# =========================================================================== + +test_that("the sketch accessors are NULL-safe", { + # A collection with no LD sketch is a legitimate state (individual-level + # inputs), so these answer NULL rather than erroring. + expect_null(pecotmr:::.ldSketchHandle(NULL)) + expect_null(pecotmr:::.ldSketchSubset(NULL, 1L)) +}) + +test_that("panel statistics report zero missingness for a sample-less panel", { + # With no samples the missing RATE is undefined as 1 - nObs/nSamp; report + # 0 per variant rather than NaN, which would poison the QC comparisons. + d0 <- matrix(numeric(0), nrow = 0L, ncol = 3L) + expect_equal(pecotmr:::.panelVariantStats(d0)$missRate, rep(0, 3L)) +}) + +test_that("panel allele frequencies are computed per variant", { + d <- matrix(c(0, 1, 2, 0, 0, 0), nrow = 2L, byrow = TRUE) + st <- pecotmr:::.panelVariantStats(d) + expect_equal(st$af, c(0, 0.25, 0.5)) + # maf folds above 0.5. + expect_equal(st$maf, pmin(st$af, 1 - st$af)) +}) + + +test_that("panel variant filtering is a no-op without a panel or variants", { + # Both early exits return the caller's ids unchanged: with no panel there + # is nothing to filter against, and with no variants nothing to filter. + expect_equal( + pecotmr:::.panelVariantFilter(NULL, c("v1", "v2")), + c("v1", "v2") + ) + expect_equal( + pecotmr:::.panelVariantFilter(NULL, character(0)), + character(0) + ) +}) + + +# =========================================================================== +# Empty sketches, the .afreq fast path, and design rank +# =========================================================================== + +test_that("emptying a sketch clears both axes", { + # An emptied sketch references no LD, so its sample axis is dead weight; + # nSamples must go to 0 alongside sampleIds or the derived dosage + # dimnames would disagree with the matrix. + expect_null(pecotmr:::.emptySketch(NULL)) + h <- new( + "GenotypeHandle", + path = "/tmp/x.gds", + format = "gds", + snpInfo = data.frame( + SNP = c("a", "b"), + CHR = "1", + BP = 1:2, + A1 = "A", + A2 = "G", + fileIdx = 1:2, + stringsAsFactors = FALSE + ), + nSamples = 2L, + sampleIds = c("s1", "s2"), + pgenPtr = NULL + ) + e <- pecotmr:::.emptySketch(h) + expect_equal(nrow(pecotmr:::getSnpInfo(e)), 0L) + expect_equal(length(pecotmr:::getSampleIds(e)), 0L) +}) + +test_that("a missing or malformed afreq sidecar degrades to no frequencies", { + # The sidecar is optional; a bad one must not take the whole filter down, + # it just falls back to reading dosage. + expect_null(pecotmr:::.panelAfreqTable("/nonexistent/prefix")) + h <- new( + "GenotypeHandle", + path = "/tmp/x.gds", + format = "gds", + snpInfo = data.frame( + SNP = c("a", "b"), + CHR = "1", + BP = 1:2, + A1 = "A", + A2 = "G", + fileIdx = 1:2, + stringsAsFactors = FALSE + ), + nSamples = 2L, + sampleIds = c("s1", "s2"), + pgenPtr = NULL + ) + # The fast path is plink2-only. + expect_null(pecotmr:::.panelAfreqMaf(h, c("a", "b"))) +}) + +test_that("collinear design columns are reported, full-rank ones are not", { + full <- matrix( + c(1, 0, 0, 1), + 2L, + 2L, + dimnames = list(NULL, c("a", "b")) + ) + expect_equal( + pecotmr:::.edfrProblematicColnames(full, full), + character(0) + ) + # b is a multiple of a: QR pivots it past the rank boundary. + dup <- cbind(a = c(1, 0), b = c(2, 0)) + expect_equal(pecotmr:::.edfrProblematicColnames(dup, dup), "b") +}) + +test_that("computeLd refuses snpIdx against an already-materialized block", { + # snpIdx selects variants FROM a panel; a bare matrix is already the + # block, so accepting it would silently ignore the subscript. + expect_error( + computeLd(matrix(rnorm(20), 10L, 2L), snpIdx = 1L), + "`snpIdx` selects variants from a genotype panel" + ) +}) + + +# =========================================================================== +# Block-indexed sources and LdData subsetting +# =========================================================================== + +test_that("a block-indexed source must be addressable by block", { + # `block` only means something for a meta file, an ldInfo frame, a matrix + # or a list of them; anything else is refused rather than silently + # returning the wrong block. + expect_error( + pecotmr:::.loadLdFromIndexed("a string", 1L, FALSE), + "cannot address a character by block" + ) +}) + +test_that("a matrix and a list of matrices both address by block", { + R <- diag(3) + dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) + expect_s4_class(pecotmr:::.loadLdFromIndexed(R, 1L, FALSE), "LdData") + # The list form picks the requested element. + both <- pecotmr:::.loadLdFromIndexed(list(R, R), 2L, FALSE) + expect_s4_class(both, "LdData") + expect_equal(length(both), 3L) +}) + +test_that("materializing genotypes is a no-op without genotypes to read", { + # Both exits return the LdData untouched: not requested, and requested + # but the source is a correlation matrix with nothing to materialize. + R <- diag(3) + dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) + ld <- pecotmr:::.ldDataFromMatrix(R, isGenotype = FALSE) + expect_identical(pecotmr:::.ldApplyMaterialize(ld, FALSE), ld) + expect_identical(pecotmr:::.ldApplyMaterialize(ld, TRUE), ld) +}) + +test_that("subsetting an LdData narrows the correlation on both axes", { + R <- diag(3) + dimnames(R) <- list(c("v1", "v2", "v3"), c("v1", "v2", "v3")) + ld <- pecotmr:::.ldDataFromMatrix(R, isGenotype = FALSE) + out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) + expect_equal(length(out), 2L) + expect_equal(dim(getCorrelation(out)), c(2L, 2L)) +}) + +# --------------------------------------------------------------------------- +# LdData narrowing and materialization: each genotype source shape (matrix, +# handle + snpIdx, mixture list) narrows differently, and only the matrix +# shape can be materialized. +# --------------------------------------------------------------------------- + +.ldcov_gr <- function(variant_ids, af = NULL) { + rp <- pecotmr:::parseVariantId(variant_ids) + rp$variant_id <- variant_ids + if (!is.null(af)) { + rp$allele_freq <- af + } + pecotmr:::.refPanelToGranges(rp) +} + +.ldcov_bm <- function(n) { + data.frame( + blockId = 1L, + chrom = "chr1", + blockStart = 100, + blockEnd = 100 * n, + size = n, + startIdx = 1L, + endIdx = n, + stringsAsFactors = FALSE + ) +} + +.ldcov_handle <- function() { + new( + "GenotypeHandle", + path = "/tmp/test.gds", + format = "gds", + snpInfo = data.frame(), + nSamples = 0L, + sampleIds = character(), + pgenPtr = NULL + ) +} + +test_that(".loadLdDedup passes through when there are no variant ids", { + # A GRanges with no variant_id column: getVariantIds() is NULL, so there + # is nothing to deduplicate against. + bare <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100, 200, 300), width = 1) + ) + ld <- LdData( + correlation = diag(3), + variants = bare, + blockMetadata = .ldcov_bm(3L) + ) + expect_null(getVariantIds(ld)) + expect_identical(pecotmr:::.loadLdDedup(ld), ld) +}) + +test_that(".ldApplyMonomorphic keeps an all-polymorphic block unchanged", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ld <- LdData( + correlation = diag(3), + variants = .ldcov_gr(v, af = c(0.2, 0.3, 0.4)), + blockMetadata = .ldcov_bm(3L) + ) + # Every allele_freq is strictly inside (0, 1), so no subset is taken. + expect_identical(pecotmr:::.ldApplyMonomorphic(ld, TRUE), ld) +}) + +test_that(".ldApplyMonomorphic needs an allele_freq column to act", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ld <- LdData( + correlation = diag(3), + variants = .ldcov_gr(v), + blockMetadata = .ldcov_bm(3L) + ) + # No frequencies to judge monomorphism by, so the request is a no-op + # rather than an error -- distinct from the all-polymorphic case. + expect_false(is_in("allele_freq", colnames(getRefPanel(ld)))) + expect_identical(pecotmr:::.ldApplyMonomorphic(ld, TRUE), ld) +}) + +test_that(".ldApplyMonomorphic drops monomorphic variants", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ld <- LdData( + correlation = diag(3), + variants = .ldcov_gr(v, af = c(0.2, 0.0, 0.4)), + blockMetadata = .ldcov_bm(3L) + ) + out <- pecotmr:::.ldApplyMonomorphic(ld, TRUE) + expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) + expect_equal(dim(getCorrelation(out)), c(2L, 2L)) +}) + +test_that(".ldApplyMaterialize leaves a mixture list alone", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + m1 <- matrix(0, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) + m2 <- matrix(1, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) + ld <- LdData( + correlation = NULL, + genotypeHandle = list(m1, m2), + mixtureWeights = c(0.5, 0.5), + variants = .ldcov_gr(v), + blockMetadata = .ldcov_bm(3L) + ) + # getGenotypes() on a mixture returns a LIST of dosage matrices; there is + # no single matrix to fold into the object. + expect_false(is.matrix(getGenotypes(ld))) + expect_identical(pecotmr:::.ldApplyMaterialize(ld, TRUE), ld) +}) + +test_that(".ldSubsetData narrows a dosage matrix by column", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + m <- matrix(0, nrow = 4L, ncol = 3L, dimnames = list(NULL, v)) + ld <- LdData( + correlation = NULL, + genotypeHandle = m, + snpIdx = NULL, + variants = .ldcov_gr(v), + blockMetadata = .ldcov_bm(3L) + ) + out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) + expect_equal(dim(pecotmr:::getGenotypeHandle(out)), c(4L, 2L)) + expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) +}) + +test_that(".ldSubsetData narrows a handle through snpIdx", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ld <- LdData( + correlation = NULL, + genotypeHandle = .ldcov_handle(), + snpIdx = c(5L, 6L, 7L), + variants = .ldcov_gr(v), + blockMetadata = .ldcov_bm(3L) + ) + out <- pecotmr:::.ldSubsetData(ld, c(1L, 3L)) + # The handle is untouched; snpIdx selects into its full snpInfo, so + # subsetting picks positions 1 and 3 OF THE INDEX, not of the file. + expect_equal(pecotmr:::getSnpIdx(out), c(5L, 7L)) + expect_equal(getVariantIds(out), c("chr1:100:A:G", "chr1:300:G:A")) +}) + +test_that(".ldSketchMatchIds returns bare ids when alleles are absent", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100, 200), width = 1) + ) + S4Vectors::mcols(gr)$SNP <- c("chr1:100:A:G", "chr1:200:C:T") + se <- SummarizedExperiment::SummarizedExperiment( + assays = list(x = matrix(0, nrow = 2L, ncol = 1L)), + rowRanges = gr + ) + # With no A1/A2 columns there is nothing to repair the ids against. + expect_equal( + pecotmr:::.ldSketchMatchIds(se), + c("chr1:100:A:G", "chr1:200:C:T") + ) +}) + +test_that(".panelVariantFilter is a no-op without a sketch", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + # An active cutoff still cannot filter anything with no panel to read + # frequencies from. + expect_equal( + pecotmr:::.panelVariantFilter(NULL, v, mafCutoff = 0.01), + v + ) + expect_equal( + pecotmr:::.panelVariantFilter(NULL, character(0), mafCutoff = 0.01), + character(0) + ) +}) + +test_that(".panelVariantFilter is a no-op when nothing matches the panel", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100, 200), width = 1) + ) + S4Vectors::mcols(gr)$SNP <- c("chr1:100:A:G", "chr1:200:C:T") + sketch <- SummarizedExperiment::SummarizedExperiment( + assays = list(x = matrix(0, nrow = 2L, ncol = 1L)), + rowRanges = gr + ) + ids <- c("chr9:999:A:G", "chr9:888:C:T") + # The sketch exists but shares no variant with the request, so there is + # no frequency to filter on and the ids pass through untouched. + expect_equal( + pecotmr:::.panelVariantFilter(sketch, ids, mafCutoff = 0.01), + ids + ) +}) + +test_that(".ldSketchNullGuard names the label in its strict error", { + expect_error( + pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", "myLabel", "strict"), + "ldSketch on `myLabel` is non-NULL" + ) + expect_error( + pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", NULL, "strict"), + "qtl ldSketch is non-NULL" + ) + # lenient tolerates the same input. + expect_true( + pecotmr:::.ldSketchNullGuard("Q", NULL, "myPipe", "myLabel", "lenient") + ) +}) + +test_that(".ldSketchCheckContent rejects panels on different chromosomes", { + mkSe <- function(chr, pos) { + g <- GenomicRanges::GRanges(chr, IRanges::IRanges(pos, width = 1)) + S4Vectors::mcols(g)$SNP <- str_c(chr, ":", pos, ":A:G") + SummarizedExperiment::SummarizedExperiment( + assays = list(x = matrix(0, nrow = length(pos), ncol = 1L)), + rowRanges = g + ) + } + expect_error( + pecotmr:::.ldSketchCheckContent( + mkSe("chr1", c(100, 200)), + mkSe("chr2", c(100, 200)), + "myPipe", + " between X and Y" + ), + "differ in column CHR between X and Y" + ) +}) + +test_that(".blockPairMessages is silent on a clean block pair", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + m <- diag(3) + rownames(m) <- colnames(m) <- v + # Cross-block correlation is zero everywhere, which is what a correct + # block structure looks like. + bm <- data.frame(startIdx = c(1L, 2L), endIdx = c(1L, 3L)) + expect_equal( + pecotmr:::.blockPairMessages(1L, 2L, bm, m, v, 3L), + character(0) + ) +}) + +test_that(".dropCollinearPickCor is reproducible under a seed", { + X <- cbind(a = c(1, 2, 3, 4, 5), b = c(1, 2, 3, 4, 5.0001)) + first <- pecotmr:::.dropCollinearPickCor(X, c(1L, 2L), FALSE, seed = 42L) + second <- pecotmr:::.dropCollinearPickCor(X, c(1L, 2L), FALSE, seed = 42L) + # Two candidates means the choice is random; the seed pins it. + expect_identical(first, second) + expect_true(first %in% c(1L, 2L)) +}) + +test_that("extractLdMatrix returns the correlation when genotypes are absent", { + v <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + ld <- LdData( + correlation = diag(3), + variants = .ldcov_gr(v), + blockMetadata = .ldcov_bm(3L) + ) + expect_false(hasGenotypes(ld)) + # wantGenotype is honoured only when genotypes exist; otherwise the + # correlation is returned rather than erroring. + expect_equal(dim(pecotmr:::extractLdMatrix(ld)), c(3L, 3L)) + expect_equal( + dim(pecotmr:::extractLdMatrix(ld, wantGenotype = TRUE)), + c(3L, 3L) + ) +}) + +# --------------------------------------------------------------------------- +# computeLd default index: with snpIdx = NULL every variant in the panel is +# used, on both the in-memory and the on-disk route. +# --------------------------------------------------------------------------- + +test_that("computeLd(panel) defaults to the panel's whole variant set", { + panel <- readGenotypes( + path = test_path("test_data", "test_variants.gds"), + format = "gds" + ) + sub <- panel[1:6, ] + R <- computeLd(sub) + expect_equal(dim(R), c(6L, 6L)) + expect_equal(unname(diag(R)), rep(1, 6L)) + # The NULL default must agree with spelling the index out. + expect_equal(unname(R), unname(computeLd(sub, snpIdx = 1:6))) +}) + +test_that("computeLd(onDisk) defaults to every variant in the panel", { + skip_if_not_installed("SNPRelate") + handle <- readGenotypeHandle( + test_path("test_data", "test_variants.gds"), + format = "gds" + ) + R <- computeLd(handle, backend = "snprelate", onDisk = TRUE) + n <- nrow(pecotmr:::getSnpInfo(handle)) + expect_equal(dim(R), c(n, n)) + expect_identical(rownames(R), pecotmr:::getSnpInfo(handle)$SNP) +}) + +test_that("computeLd(onDisk) applies shrinkage toward the identity", { + skip_if_not_installed("SNPRelate") + handle <- readGenotypeHandle( + test_path("test_data", "test_variants.gds"), + format = "gds" + ) + idx <- 1:6 + plain <- computeLd(handle, snpIdx = idx, backend = "snprelate", + onDisk = TRUE) + shrunk <- computeLd(handle, snpIdx = idx, backend = "snprelate", + onDisk = TRUE, shrinkage = 0.5) + # (1 - s) * R + s * I: off-diagonals halve, the diagonal stays 1. + expect_equal(unname(diag(shrunk)), rep(1, length(idx))) + expect_equal( + unname(shrunk[upper.tri(shrunk)]), + unname(0.5 * plain[upper.tri(plain)]) + ) +}) + +# --------------------------------------------------------------------------- +# .ldInfoBlock: an `ldInfo` row names the LD matrix, and the variant metadata +# is either named alongside it or auto-detected from the LD path. +# --------------------------------------------------------------------------- + +test_that(".ldInfoBlock reads a block with an explicit SNP_file", { + ldFile <- file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.txt.xz" + ) + bimFile <- file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.bim" + ) + out <- pecotmr:::.ldInfoBlock( + data.frame( + LD_file = ldFile, + SNP_file = bimFile, + stringsAsFactors = FALSE + ), + 1L + ) + # Both ldInfo sources return an LdData, so the post-load chain does not + # have to branch on which kind of LD_file it was given. + expect_s4_class(out, "LdData") + expect_equal(dim(getCorrelation(out)), c(5L, 5L)) + expect_equal( + head(getVariantIds(out), 3L), + c("chr1:1000:A:G", "chr1:1040:A:G", "chr1:1080:A:G") + ) + # The .bim coordinates are carried through rather than replaced with the + # chrNA:1..n placeholders a bare matrix would get. + refPanel <- getRefPanel(out) + expect_equal(as.character(refPanel$chrom[[1L]]), "chr1") + expect_equal(as.integer(refPanel$pos[[1L]]), 1000L) +}) + +test_that("loadLdMatrix reads an ldInfo table of precomputed LD", { + info <- data.frame( + LD_file = file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.txt.xz" + ), + SNP_file = file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.bim" + ), + stringsAsFactors = FALSE + ) + # End-to-end: the whole post-load chain (dedup, monomorphic, subsample, + # materialize) runs against a precomputed block, not just a genotype one. + out <- loadLdMatrix(info, block = 1L) + expect_s4_class(out, "LdData") + expect_equal(length(getVariantIds(out)), 5L) + expect_equal(unname(diag(getCorrelation(out))), rep(1, 5L)) +}) + +test_that(".ldInfoBlock auto-detects the variant file beside the matrix", { + # Auto-detection APPENDS the suffix to the LD path, so the companion of + # `block.cor.xz` is `block.cor.xz.bim` -- not a sibling with the LD + # extension swapped out. + dir <- withr::local_tempdir() + ldFile <- file.path(dir, "block.cor.xz") + file.copy( + file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.txt.xz" + ), + ldFile + ) + file.copy( + file.path( + geno_test_data_dir, + "LD_block_1.chr1_1000_1200.float16.bim" + ), + str_c(ldFile, ".bim") + ) + auto <- pecotmr:::.ldInfoBlock( + data.frame(LD_file = ldFile, stringsAsFactors = FALSE), + 1L + ) + explicit <- pecotmr:::.ldInfoBlock( + data.frame( + LD_file = ldFile, + SNP_file = str_c(ldFile, ".bim"), + stringsAsFactors = FALSE + ), + 1L + ) + expect_identical(auto, explicit) + expect_s4_class(auto, "LdData") + expect_equal(dim(getCorrelation(auto)), c(5L, 5L)) +}) + +test_that(".ldInfoBlock requires an LD_file column", { + expect_error( + pecotmr:::.ldInfoBlock(data.frame(x = 1), 1L), + "needs an `LD_file` column" + ) +}) + +test_that(".panelAfreqMaf returns NULL when no sidecar exists at all", { + skip_if_not_installed("pgenlibr") + # This plink2 fixture ships without an .afreq, so every shard's table is + # absent -- distinct from the partial-sidecar case above. + handle <- readGenotypeHandle( + test_path("test_data/test_variants_chr22"), + format = "plink2" + ) + expect_equal(pecotmr:::getFormat(handle), "plink2") + expect_null( + pecotmr:::.panelAfreqMaf( + handle, + as.character(pecotmr:::getSnpInfo(handle)$SNP) + ) + ) +}) diff --git a/tests/testthat/test_ldData.R b/tests/testthat/test_ldData.R index 2642b96c..7373effd 100644 --- a/tests/testthat/test_ldData.R +++ b/tests/testthat/test_ldData.R @@ -852,3 +852,21 @@ test_that("blockMetadata takes ranges as well as tables", { expect_s4_class(ld, "LdData") } }) + + +test_that("show() labels a list-valued correlation block-diagonal", { + # Only single-matrix LdData objects were ever printed, so the other arm + # of the label was never produced. + ld <- makeTestLdDataMultiBlock(sizes = c(2L, 2L)) + expect_output(show(ld), "block-diagonal") + expect_output(show(ld), "LdData: 4 variants") +}) + + +test_that("an LdData refuses to be subset", { + # Narrowing would leave the correlation and snpIdx describing variants + # that are no longer present, so `[` errors rather than half-working. + ld <- makeTestLdData(n = 3L) + expect_error(ld[1:2], "an LdData cannot be subset") + expect_error(ld[1:2, ], "an LdData cannot be subset") +}) diff --git a/tests/testthat/test_manifestLoaders.R b/tests/testthat/test_manifestLoaders.R index f9e4e486..0c7cf008 100644 --- a/tests/testthat/test_manifestLoaders.R +++ b/tests/testthat/test_manifestLoaders.R @@ -1678,3 +1678,81 @@ test_that("loadGwasSumStatsFromManifest splits by LD block when asked", { # Same variants either way, just distributed across the blocks. expect_equal(sum(lengths(split)), sum(lengths(plain))) }) + + +test_that("containment checking is skipped when there is no LD sketch", { + # Nothing to contain the variants in, so the check is a no-op rather than + # an error about a missing panel. + expect_null( + pecotmr:::.qtlSumStatsCheckContainment(NULL, NULL, NULL, 0.5) + ) +}) + +test_that(".deriveAllelesFromVariantId passes through with no id column", { + df <- data.frame(foo = 1, bar = 2) + # Neither an allele column nor a resolvable variant_id: the missing-field + # error belongs to the caller, so nothing is derived or raised here. + expect_identical( + pecotmr:::.deriveAllelesFromVariantId( + df, + order = c("A1", "A2"), + mapping = NULL, + label = "lab" + ), + df + ) +}) + +test_that(".resolveGenoCov accepts a single genotypeCovariatePath", { + dir <- withr::local_tempdir() + covPath <- file.path(dir, "cov.tsv") + cov <- data.frame( + id = c("c1", "c2"), + s1 = c(0.1, 0.3), + s2 = c(0.2, 0.4), + stringsAsFactors = FALSE + ) + readr::write_tsv(cov, covPath, progress = FALSE) + rows <- data.frame( + genotypeCovariatePath = c("cov.tsv", "cov.tsv", NA), + stringsAsFactors = FALSE + ) + # Repeated identical paths collapse to one; only a genuine conflict errors. + out <- pecotmr:::.resolveGenoCov(rows, "s1", dir, FALSE, NULL) + expect_true(is.matrix(out)) + expect_equal(nrow(out), 2L) + conflicting <- data.frame( + genotypeCovariatePath = c("a.tsv", "b.tsv"), + stringsAsFactors = FALSE + ) + expect_error( + pecotmr:::.resolveGenoCov(conflicting, "s1", dir, FALSE, NULL), + "references multiple genotypeCovariatePath values" + ) + # Blank / NA paths leave nothing to resolve, which yields the empty + # covariate matrix rather than an error. + none <- data.frame( + genotypeCovariatePath = c(NA, ""), + stringsAsFactors = FALSE + ) + empty <- pecotmr:::.resolveGenoCov(none, "s1", dir, FALSE, NULL) + expect_true(is.matrix(empty)) + expect_equal(dim(empty), c(0L, 0L)) +}) + +test_that(".readTabixRegion returns a bare tibble for a headerless file", { + skip_if_not_installed("Rsamtools") + dir <- withr::local_tempdir() + plain <- file.path(dir, "noheader.tsv") + writeLines(c("chr1\t100\t200\tA", "chr1\t300\t400\tB"), plain) + bgz <- Rsamtools::bgzip(plain, file.path(dir, "noheader.tsv.bgz"), + overwrite = TRUE) + Rsamtools::indexTabix(bgz, seq = 1L, start = 2L, end = 3L) + # With no "#" header line there are no column names to build an empty + # frame from, so the miss returns a column-less tibble. + expect_length(Rsamtools::headerTabix(Rsamtools::TabixFile(bgz))$header, 0L) + out <- pecotmr:::.readTabixRegion(bgz, "chr9:1-100") + expect_s3_class(out, "tbl_df") + expect_equal(nrow(out), 0L) + expect_equal(ncol(out), 0L) +}) diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index 271410bb..09b9a690 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -575,12 +575,14 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { skip_if_not_installed("flashier") data(qtlSumStatsMulticontextExample) ss <- qtlSumStatsMulticontextExample - # Supplying `null` triggers estimate_null_correlation_simple; leaving nPcs - # NULL exercises the `nPcs <- ncol(Bhat) - 1` default in the cov_* chain. + # `residualCorrelationMethod = "simple"` runs + # estimate_null_correlation_simple on the null set; leaving nPcs NULL + # exercises the `nPcs <- ncol(Bhat) - 1` default in the cov_* chain. res <- suppressMessages(suppressWarnings( mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + residualCorrelationMethod = "simple", setSeed = 1L ) )) @@ -594,6 +596,160 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { expect_equal(sum(res$w), 1, tolerance = 1e-6) }) +# --------------------------------------------------------------------------- +# residualCorrelationMethod +# +# Vhat used to be chosen by inspecting which partitions were present, so a +# caller without a null set silently assumed zero residual correlation. The +# choice is now always explicit. +# --------------------------------------------------------------------------- + +test_that("the default is identity regardless of which partitions are given", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + # The default must not depend on data shape -- that was the old silent + # behaviour this argument replaced. + withNull <- suppressMessages(suppressWarnings(mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + setSeed = 1L + ))) + withoutNull <- suppressMessages(suppressWarnings(mashPipeline( + list(strong = ss, random = ss), + alpha = 0, + setSeed = 1L + ))) + explicit <- suppressMessages(suppressWarnings(mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + residualCorrelationMethod = "identity", + setSeed = 1L + ))) + expect_equal(withNull$U, withoutNull$U) + expect_equal(withNull$w, withoutNull$w) + expect_equal(withNull$U, explicit$U) +}) + +test_that("an unused null partition is reported", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + # Assembling a null set and still getting identity is more often an + # oversight than an intent, so it must not pass silently. + expect_message( + suppressWarnings(mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + setSeed = 1L + )), + "does not use it" + ) + # Naming identity explicitly does not change that the set is unused. + expect_message( + suppressWarnings(mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + residualCorrelationMethod = "identity", + setSeed = 1L + )), + "'null' partition" + ) +}) + +test_that("no unused-null notice when there is nothing to ignore", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + noNull <- function() { + suppressWarnings(mashPipeline( + list(strong = ss, random = ss), + alpha = 0, + setSeed = 1L + )) + } + expect_no_message(noNull(), message = "'null' partition") + # Nor when the null set is actually being consumed. + usesNull <- function() { + suppressWarnings(mashPipeline( + list(strong = ss, random = ss, null = ss), + alpha = 0, + residualCorrelationMethod = "simple", + setSeed = 1L + )) + } + expect_no_message(usesNull(), message = "does not use it") +}) + +test_that("mashPipeline honours a data-driven residualCorrelationMethod", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + sl <- list(strong = ss, random = ss, null = ss) + identityFit <- suppressMessages(suppressWarnings(mashPipeline( + sl, + alpha = 0, + residualCorrelationMethod = "identity", + setSeed = 1L + ))) + simpleFit <- suppressMessages(suppressWarnings(mashPipeline( + sl, + alpha = 0, + residualCorrelationMethod = "simple", + setSeed = 1L + ))) + # A different V has to move the fit, or the argument is not reaching it. + expect_false(isTRUE(all.equal(identityFit$w, simpleFit$w))) +}) + +test_that("mashPipeline rejects an unknown residualCorrelationMethod", { + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + expect_error( + mashPipeline( + list(strong = ss, random = ss), + alpha = 0, + residualCorrelationMethod = "bogus" + ), + "bogus" + ) +}) + +test_that("a method needing a partition it lacks errors through mashPipeline", { + skip_if_not_installed("mashr") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + expect_error( + mashPipeline( + list(strong = ss, random = ss), + alpha = 0, + residualCorrelationMethod = "simple" + ), + "requires a 'null' entry" + ) +}) + +test_that("a supplied residualCorrelation wins over the method", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + # 'simple' would error without a null set; the supplied matrix means the + # estimator is never consulted. + res <- suppressMessages(suppressWarnings(mashPipeline( + list(strong = ss, random = ss), + alpha = 0, + residualCorrelation = diag(3), + residualCorrelationMethod = "simple", + setSeed = 1L + ))) + expect_named(res, c("U", "w")) +}) + # --------------------------------------------------------------------------- # mashResidualCorrelation — the Vhat estimator extracted from mashPipeline. # --------------------------------------------------------------------------- @@ -641,7 +797,7 @@ test_that("mashResidualCorrelation(simple) errors without a null entry", { ) }) -test_that("mashResidualCorrelation(simple_specific) returns a null correlation", { +test_that("mashResidualCorrelation(simpleSpecific) returns a null correlation", { skip_if_not_installed("mashr") data(qtlSumStatsMulticontextExample) ss <- qtlSumStatsMulticontextExample @@ -649,7 +805,7 @@ test_that("mashResidualCorrelation(simple_specific) returns a null correlation", mashResidualCorrelation( list(strong = ss, null = ss), alpha = 0, - method = "simple_specific" + method = "simpleSpecific" ) )) expect_equal(dim(v), c(3L, 3L)) @@ -715,7 +871,7 @@ test_that("mashResidualCorrelation errors when a method's inputs are missing", { # --------------------------------------------------------------------------- # mashPriorCovariances — the covariance + weight estimator extracted from # mashPipeline. Default builds every non-udr component (canonical + pca + -# flash + flash_nonneg) refined by cov_ed. +# flash + flashNonneg) refined by cov_ed. # --------------------------------------------------------------------------- test_that("mashPriorCovariances computes the default (all-but-udr) prior", { @@ -790,7 +946,7 @@ test_that("mashPriorCovariances validates a supplied prior", { ) }) -test_that("mashPriorCovariances(flash_nonneg) adds components vs flash-only", { +test_that("mashPriorCovariances(flashNonneg) adds components vs flash-only", { skip_if_not_installed("mashr") skip_if_not_installed("flashier") data(qtlSumStatsMulticontextExample) @@ -810,7 +966,7 @@ test_that("mashPriorCovariances(flash_nonneg) adds components vs flash-only", { list(strong = ss), alpha = 0, vhat = diag(3), - components = c("canonical", "pca", "flash", "flash_nonneg"), + components = c("canonical", "pca", "flash", "flashNonneg"), nPcs = 2L, setSeed = 1L ) @@ -1030,6 +1186,7 @@ test_that("mashPipeline result == composing the two extracted building blocks", mashPipeline( list(strong = ss, random = ss, null = ss), alpha = 0, + residualCorrelationMethod = "simple", setSeed = 1L ) )) @@ -1101,6 +1258,74 @@ test_that("mashModelFit validates the prior and the fitOn entry", { ) }) +# --------------------------------------------------------------------------- +# Prior-shape normalisation (.mashAsUlist) +# +# The two producers disagree on shape: mashCovarianceComponents() returns a +# bare Ulist, mashPriorCovariances() wraps it as list(U, w, loglik). Every +# consumer must take either, so a chain can be written without reaching for +# `$U`. +# --------------------------------------------------------------------------- + +test_that(".mashAsUlist unwraps the wrapper and passes a bare Ulist through", { + ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) + wrapped <- list(U = ulist, w = c(0.5, 0.5), loglik = -10) + + expect_equal(pecotmr:::.mashAsUlist(wrapped), ulist) + expect_equal(pecotmr:::.mashAsUlist(ulist), ulist) + expect_null(pecotmr:::.mashAsUlist(NULL)) +}) + +test_that(".mashAsUlist does not mistake a covariance named U for the wrapper", { + # A genuine Ulist entry named "U" is a matrix, not a list, which is what + # keeps the two shapes distinguishable. + ulist <- list(U = diag(3), identity = diag(3)) + expect_equal(pecotmr:::.mashAsUlist(ulist), ulist) +}) + +test_that("mashModelFit accepts either prior shape and fits identically", { + skip_if_not_installed("mashr") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) + wrapped <- list(U = ulist, w = NULL, loglik = NULL) + + fit <- function(prior) { + suppressMessages(suppressWarnings(mashModelFit( + list(random = ss), + alpha = 0, + priorCovariances = prior, + vhat = diag(3), + setSeed = 1L + ))) + } + expect_equal(fit(wrapped)$loglik, fit(ulist)$loglik) +}) + +test_that("mashPriorCovariances accepts either shape for its two prior args", { + skip_if_not_installed("mashr") + data(qtlSumStatsMulticontextExample) + ss <- qtlSumStatsMulticontextExample + sl <- list(strong = ss, random = ss) + ulist <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) + wrapped <- list(U = ulist, w = NULL, loglik = NULL) + + bare <- suppressMessages(suppressWarnings(mashPriorCovariances( + sl, + alpha = 0, + vhat = diag(3), + priorCovariances = ulist + ))) + wrap <- suppressMessages(suppressWarnings(mashPriorCovariances( + sl, + alpha = 0, + vhat = diag(3), + priorCovariances = wrapped + ))) + expect_equal(names(wrap$U), names(bare$U)) + expect_equal(wrap$w, bare$w) +}) + test_that("mashPosterior returns posterior matrices with covariance", { skip_if_not_installed("mashr") data(qtlSumStatsMulticontextExample) @@ -1535,3 +1760,49 @@ test_that("mashPosterior: default (NULL) vhat and excludeCondition dropping ever "drops every condition" ) }) + + +test_that("contrast rows fall back to the positional index when unnamed", { + # posteriorMean usually carries feature rownames, but an unnamed matrix + # still needs a feature_id -- the position, not NA, so the contrast table + # stays joinable. + f <- pecotmr:::.mashContrastDf + pm <- matrix(1:4, 2L, 2L) + d <- f( + 1L, + pm, + "c1", + matrix(0.1, 2L, 1L), + matrix(0.2, 2L, 1L), + matrix(0.3, 2L, 1L) + ) + expect_equal(d$feature_id, "1") + rownames(pm) <- c("f1", "f2") + d2 <- f( + 2L, + pm, + "c1", + matrix(0.1, 2L, 1L), + matrix(0.2, 2L, 1L), + matrix(0.3, 2L, 1L) + ) + expect_equal(d2$feature_id, "f2") +}) + +test_that(".mashUdFit re-raises an unrelated udr failure unchanged", { + skip_if_not_installed("udr") + local_mocked_bindings(.mashUdControl = function(...) list(), + .package = "pecotmr") + # Only the ud_ted i.i.d. incompatibility is rewrapped; anything else must + # surface as itself rather than being swallowed into a NULL fit. + expect_error( + with_mocked_bindings( + pecotmr:::.mashUdFit( + NULL, list(Bhat = matrix(0, 2L, 2L)), "ud_ted", list() + ), + ud_fit = function(...) stop("totally unrelated failure"), + .package = "udr" + ), + "totally unrelated failure" + ) +}) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index 649cc612..f678c030 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -921,7 +921,7 @@ test_that("filterMixtureComponents subsets conditions", { # =========================================================================== # ========================================================================= -# mrmashWrapper.R: compute_w0 (lines 284-298) +# mrmashWrapper.R: computeW0 (lines 284-298) # ========================================================================= # =========================================================================== @@ -2013,3 +2013,43 @@ test_that("mashInput: independentVariants matches across allele flip + chr prefi expect_true(length(rn_ids) > 0L) expect_true(all(rn_ids %in% paste0("chr1:", c(100, 200, 300), ":A:G"))) }) + + +test_that("a NULL partition passes through as NULL", { + expect_null(pecotmr:::.mashAsDataFrameOrNull(NULL)) + # A matrix becomes a base data.frame, keeping the variant-id rownames the + # downstream combine step relies on. + m <- matrix( + 1:4, + 2L, + 2L, + dimnames = list(c("v1", "v2"), c("a", "b")) + ) + out <- pecotmr:::.mashAsDataFrameOrNull(m) + expect_s3_class(out, "data.frame") + expect_equal(rownames(out), c("v1", "v2")) +}) + +test_that(".qtlSumStatsFromMatrix synthesises coords for unparseable ids", { + local_mocked_bindings( + parseVariantId = function(...) stop("bad"), + .package = "pecotmr" + ) + out <- pecotmr:::.qtlSumStatsFromMatrix( + vids = c("weird1", "weird2"), + nCond = 1L, + study = "s1", + ldSketch = NULL, + context = "cA", + trait = "g1", + genome = "hg19", + role = "input", + mcolFn = function(i, k) list(Z = c(1, 2)) + ) + expect_s4_class(out, "QtlSumStats") + gr <- out[[1L]] + # Ids that carry no coordinates land on chr1 at their own row index, so + # the object stays well-formed instead of failing to build. + expect_equal(as.character(GenomicRanges::seqnames(gr)), c("chr1", "chr1")) + expect_equal(GenomicRanges::start(gr), c(1L, 2L)) +}) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R index e992c3c4..83653d2b 100644 --- a/tests/testthat/test_qtlAssociationPostprocess.R +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -474,3 +474,48 @@ test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on t )) expect_equal(length(sig), expN) }) + +test_that(".qapSignificanceMask returns empty masks for an unknown method", { + # Both public callers wrap this in arg_match(), so the fall-through is + # only reachable by calling the helper directly. It is tested here so the + # contract is explicit: an unrecognized method yields the untouched empty + # masks rather than erroring or silently returning the wrong ones. + g <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(100, 200), width = 1) + ) + S4Vectors::mcols(g)$variant_id <- c("chr1:100:A:G", "chr1:200:C:T") + S4Vectors::mcols(g)$Z <- c(1, 2) + S4Vectors::mcols(g)$N <- c(10L, 10L) + qss <- QtlSumStats( + study = "s1", context = "c1", trait = "g1", + entry = list(g), genome = "hg19" + ) + local_mocked_bindings( + getQcInfo = function(x) { + list(associationPostprocess = list( + fdrThreshold = 0.05, + pvalueCol = "pval_nominal" + )) + }, + .qapEmptyMask = function(i, x, pcol) str_c("EMPTY", i), + .package = "pecotmr" + ) + expect_equal( + pecotmr:::.qapSignificanceMask(qss, "not_a_method", 0.05), + list("EMPTY1") + ) +}) + +test_that(".qapPermutationCols reuses a supplied q_beta", { + x <- list( + p_beta = c(0.01, 0.2), + q_beta = c(0.02, 0.3), + beta_shape1 = c(1, 1), + beta_shape2 = c(1, 1), + pval_nominal = c(0.01, 0.2) + ) + cols <- pecotmr:::.qapPermutationCols(x, 0.05) + # q_beta is already present, so it is not recomputed or re-added. + expect_setequal(names(cols), c("fdr_beta", "p_nominal_threshold")) +}) diff --git a/tests/testthat/test_qtlEnrichmentPipeline.R b/tests/testthat/test_qtlEnrichmentPipeline.R index 5e9e7484..6ebe5006 100644 --- a/tests/testthat/test_qtlEnrichmentPipeline.R +++ b/tests/testthat/test_qtlEnrichmentPipeline.R @@ -1056,3 +1056,44 @@ test_that("qtlEnrichmentPipeline: a tuple with no usable QTL regions warns and i ) expect_equal(nrow(out), 0L) }) + +test_that(".enrRunEnrichment turns a stored alignment failure into a warning", { + cnd <- simpleCondition("boom") + class(cnd) <- c("simpleError", "error", "condition") + # The alignment failure was captured earlier and stored in place of the + # aligned data; re-signalling it here routes it through the same handler + # a live failure would take. + expect_warning( + out <- pecotmr:::.enrRunEnrichment( + 1L, + gwasPip = NULL, + k = 1L, + p = list(alignedByTuple = list(cnd)) + ), + "qtlEnrichment failed" + ) + expect_null(out) +}) + +test_that(".enrBuildQtlRegionsList reads prior variance under either name", { + pip <- c(v1 = 0.5, v2 = 0.5) + run <- function(fit) { + local_mocked_bindings( + .enrMatchRows = function(qtlFmr, ident) 1L, + .fmrRowParts = function(qtlFmr, i) "parts", + getSusieFit = function(parts) fit, + .package = "pecotmr" + ) + pecotmr:::.enrBuildQtlRegionsList("fmr", "ident") + } + base <- list(alpha = matrix(0.5, 1L, 2L), pip = pip) + # `V` is susie's name for it; `prior_variance` is the older one. Either + # is accepted, and a fit carrying neither is skipped rather than kept + # with a NULL prior. + expect_equal(run(c(base, list(V = 0.7)))[[1L]]$prior_variance, 0.7) + expect_equal( + run(c(base, list(prior_variance = 0.3)))[[1L]]$prior_variance, + 0.3 + ) + expect_length(run(base), 0L) +}) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index e7fbcc28..efd2c577 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -603,3 +603,63 @@ test_that("combineQtlSumStats() passes a lone input through and validates", { "every input must be a QtlSumStats" ) }) + + +# =========================================================================== +# Trait-distance annotation and validity messages +# =========================================================================== + +test_that("trait distances are added to an entry that carries no mcols", { + # Regression: mcols() on a bare GRanges is a zero-COLUMN DataFrame that + # still has one row per variant. Swapping it for DataFrame(row.names = + # NULL) discarded the row count and the assignment died with + # "2 elements in value to replace 0 elements". + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(10L, 20L), width = 1L) + ) + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(5L, width = 1L)) + out <- pecotmr:::.qssAppendTraitDist(1L, list(gr), tp) + expect_equal(S4Vectors::mcols(out)$tss_distance, c(5L, 15L)) + expect_equal(S4Vectors::mcols(out)$tes_distance, c(5L, 15L)) +}) + +test_that("existing mcols survive the trait-distance annotation", { + gr <- GenomicRanges::GRanges( + "chr1", + IRanges::IRanges(c(10L, 20L), width = 1L) + ) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(z = c(1.5, 2.5)) + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(5L, width = 1L)) + out <- pecotmr:::.qssAppendTraitDist(1L, list(gr), tp) + expect_equal( + colnames(S4Vectors::mcols(out)), + c("z", "tss_distance", "tes_distance") + ) + expect_equal(S4Vectors::mcols(out)$z, c(1.5, 2.5)) +}) + +test_that("an entry with no variants is returned untouched", { + gr0 <- GenomicRanges::GRanges() + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(5L, width = 1L)) + expect_equal(length(pecotmr:::.qssAppendTraitDist(1L, list(gr0), tp)), 0L) +}) + +test_that("validity names the identity columns that are missing", { + data(qtlSumStatsExample) + bad <- qtlSumStatsExample + S4Vectors::mcols(bad)$trait <- NULL + expect_equal( + pecotmr:::.qssCheckRequiredCols(bad), + "missing columns: trait" + ) + expect_null(pecotmr:::.qssCheckRequiredCols(qtlSumStatsExample)) +}) + +test_that(".appendTraitDistances is a no-op without a trait position", { + entry <- list( + GenomicRanges::GRanges("chr1", IRanges::IRanges(100, width = 1)) + ) + # No anchor to measure TSS/TES distance from, so entries pass through. + expect_identical(pecotmr:::.appendTraitDistances(entry, NULL), entry) +}) diff --git a/tests/testthat/test_regularizedRegressionWrappers.R b/tests/testthat/test_regularizedRegressionWrappers.R index cec64859..18007f5a 100644 --- a/tests/testthat/test_regularizedRegressionWrappers.R +++ b/tests/testthat/test_regularizedRegressionWrappers.R @@ -82,29 +82,29 @@ test_that("fitSusieInfThenSusieRss returns two fits", { # === Tests migrated from test_mrmashWrapper.R (mr.mash + glasso/glmnet coef helpers) === -test_that("compute_w0 returns uniform weights when ncomps == 1", { +test_that("computeW0 returns uniform weights when ncomps == 1", { Bhat <- matrix(c(1, 0, 0, 2, 0, 0), nrow = 3, ncol = 2) - result <- pecotmr:::compute_w0(Bhat, ncomps = 1) + result <- pecotmr:::computeW0(Bhat, ncomps = 1) expect_equal(result, 1) }) -test_that("compute_w0 handles all-zero Bhat by returning uniform weights", { +test_that("computeW0 handles all-zero Bhat by returning uniform weights", { # When Bhat is all zero, prop_nonzero = 0 # w0 = c(1, 0, ..., 0) => sum(w0 != 0) < 2 => fallback to uniform Bhat <- matrix(0, nrow = 5, ncol = 3) - result <- pecotmr:::compute_w0(Bhat, ncomps = 4) + result <- pecotmr:::computeW0(Bhat, ncomps = 4) expect_equal(result, rep(1 / 4, 4)) expect_equal(sum(result), 1) }) -test_that("compute_w0 distributes weight based on nonzero rows when ncomps > 1", { +test_that("computeW0 distributes weight based on nonzero rows when ncomps > 1", { # 2 out of 4 rows have nonzero entries Bhat <- matrix(0, nrow = 4, ncol = 2) Bhat[1, 1] <- 1 Bhat[3, 2] <- 2 - result <- pecotmr:::compute_w0(Bhat, ncomps = 3) + result <- pecotmr:::computeW0(Bhat, ncomps = 3) expect_equal(length(result), 3) expect_equal(sum(result), 1, tolerance = 1e-10) # First element should be (1 - prop_nonzero) = 0.5 @@ -112,10 +112,10 @@ test_that("compute_w0 distributes weight based on nonzero rows when ncomps > 1", }) # ========================================================================= -# mrmashWrapper.R: rescale_cov_w0 (lines 300-329) +# mrmashWrapper.R: rescaleCovW0 (lines 300-329) # ========================================================================= -test_that("rescale_cov_w0 removes null component and renormalizes", { +test_that("rescaleCovW0 removes null component and renormalizes", { w0 <- c( null = 0.3, XtX_1 = 0.2, @@ -123,22 +123,22 @@ test_that("rescale_cov_w0 removes null component and renormalizes", { FLASH_1 = 0.15, FLASH_2 = 0.25 ) - result <- pecotmr:::rescale_cov_w0(w0) + result <- pecotmr:::rescaleCovW0(w0) expect_false("null" %in% names(result)) expect_equal(sum(result), 1, tolerance = 1e-10) }) -test_that("rescale_cov_w0 handles all-zero non-null weights", { +test_that("rescaleCovW0 handles all-zero non-null weights", { w0 <- c(null = 1.0, XtX_1 = 0, XtX_2 = 0, FLASH_1 = 0) - result <- pecotmr:::rescale_cov_w0(w0) + result <- pecotmr:::rescaleCovW0(w0) # All non-null weights are zero -> equal weights expect_equal(sum(result), 1, tolerance = 1e-10) expect_true(all(result == result[1])) # all equal }) -test_that("rescale_cov_w0 groups correctly by prior group prefix", { +test_that("rescaleCovW0 groups correctly by prior group prefix", { w0 <- c( null = 0.5, PCA_1 = 0.1, @@ -146,7 +146,7 @@ test_that("rescale_cov_w0 groups correctly by prior group prefix", { tFLASH_1 = 0.1, tFLASH_2 = 0.1 ) - result <- pecotmr:::rescale_cov_w0(w0) + result <- pecotmr:::rescaleCovW0(w0) expect_true("PCA" %in% names(result)) expect_true("tFLASH" %in% names(result)) expect_equal(sum(result), 1, tolerance = 1e-10) @@ -625,9 +625,9 @@ test_that("lassosumRssWeights returns length-p weights and records the selection f <- .rrwStatLd() w <- lassosumRssWeights(f$stat, f$LD) expect_length(w, f$p) - expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "ld_quadratic") + expect_equal(unname(attr(w, "lassosum_selection")["mode"]), "ldQuadratic") expect_length( - lassosumRssWeights(f$stat, f$LD, selection = "min_fbeta"), + lassosumRssWeights(f$stat, f$LD, selection = "minFbeta"), f$p ) }) @@ -658,10 +658,10 @@ test_that("prsCsWeights and sdprWeights follow the (stat, LD) contract", { ) }) -test_that("mrAshRssWeights returns posterior-mean weights of length p", { +test_that("mrashRssWeights returns posterior-mean weights of length p", { skip_if_not_installed("susieR") f <- .rrwStatLd() - w <- mrAshRssWeights( + w <- mrashRssWeights( f$stat, f$LD, varY = 1, @@ -742,7 +742,7 @@ test_that(".lassosumSelectMinFbeta picks the minimum-fbeta candidate", { data.frame(fbeta = c(3, 1, 2, 4)) ) expect_equal(r$index, 2) - expect_equal(r$mode, "min_fbeta") + expect_equal(r$mode, "minFbeta") expect_equal(r$beta, cb[, 2]) }) @@ -751,7 +751,7 @@ test_that(".lassosumSelectLdQuadratic scores candidates by c'b / sqrt(b'Rb)", { set.seed(8) cb <- matrix(rnorm(f$p * 4), f$p, 4) r <- pecotmr:::.lassosumSelectLdQuadratic(cb, f$stat$b, f$LD) - expect_equal(r$mode, "ld_quadratic") + expect_equal(r$mode, "ldQuadratic") expect_true(r$index %in% seq_len(4)) expect_equal(r$beta, cb[, r$index]) }) diff --git a/tests/testthat/test_relatednessQc.R b/tests/testthat/test_relatednessQc.R index 41f5936f..50388c3e 100644 --- a/tests/testthat/test_relatednessQc.R +++ b/tests/testthat/test_relatednessQc.R @@ -16,7 +16,7 @@ no_related_pairs_remain <- function( all(kept[[value]] < threshold) } -test_that("maximize_unrelated removes related individuals and leaves clean set", { +test_that("maximizeUnrelated removes related individuals and leaves clean set", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") @@ -32,7 +32,7 @@ test_that("maximize_unrelated removes related individuals and leaves clean set", result <- filterRelatedness( relatedness = rel, relatednessThreshold = threshold, - analysisType = "maximize_unrelated" + analysisType = "maximizeUnrelated" ) expect_type(result, "character") @@ -55,7 +55,7 @@ test_that("no related pairs returns empty exclusion vector", { result <- filterRelatedness( relatedness = rel, relatednessThreshold = threshold, - analysisType = "maximize_unrelated" + analysisType = "maximizeUnrelated" ) expect_type(result, "character") @@ -82,7 +82,7 @@ test_that("large component pre-pruning removes individuals", { result <- filterRelatedness( relatedness = rel, relatednessThreshold = threshold, - analysisType = "maximize_unrelated", + analysisType = "maximizeUnrelated", maxComponentSize = 10, verbose = TRUE ) @@ -93,7 +93,7 @@ test_that("large component pre-pruning removes individuals", { expect_true(no_related_pairs_remain(rel, result, threshold)) }) -test_that("maximize_cases preferentially retains cases", { +test_that("maximizeCases preferentially retains cases", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") @@ -118,7 +118,7 @@ test_that("maximize_cases preferentially retains cases", { result <- filterRelatedness( relatedness = rel, relatednessThreshold = threshold, - analysisType = "maximize_cases", + analysisType = "maximizeCases", phenoData = pheno, phenoCol = "pheno" ) @@ -133,7 +133,7 @@ test_that("maximize_cases preferentially retains cases", { expect_true(no_related_pairs_remain(rel, result, threshold)) }) -test_that("maximize_cases errors without pheno_data", { +test_that("maximizeCases errors without phenoData", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") @@ -148,13 +148,13 @@ test_that("maximize_cases errors without pheno_data", { filterRelatedness( relatedness = rel, relatednessThreshold = 0.125, - analysisType = "maximize_cases" + analysisType = "maximizeCases" ), "Must provide phenoData" ) }) -test_that("maximize_cases excludes a control listed as IID1 paired with a kept case", { +test_that("maximizeCases excludes a control listed as IID1 paired with a kept case", { skip_if_not_installed("igraph") skip_if_not_installed("plinkQC") @@ -176,7 +176,7 @@ test_that("maximize_cases excludes a control listed as IID1 paired with a kept c result <- filterRelatedness( relatedness = rel, relatednessThreshold = 0.125, - analysisType = "maximize_cases", + analysisType = "maximizeCases", phenoData = pheno ) @@ -214,7 +214,7 @@ test_that("iterative cleanup loops and warns when related pairs persist", { result <- filterRelatedness( relatedness = rel, relatednessThreshold = 0.125, - analysisType = "maximize_unrelated", + analysisType = "maximizeUnrelated", maxIterations = 2L, verbose = TRUE ), diff --git a/tests/testthat/test_rrDispatch.R b/tests/testthat/test_rrDispatch.R index 937a9fee..8e2e53ea 100644 --- a/tests/testthat/test_rrDispatch.R +++ b/tests/testthat/test_rrDispatch.R @@ -88,7 +88,7 @@ test_that("lassosumRssWeights dispatches to lassosumRss once per s value", { stat = stat, LD = R, s = c(0.2, 0.9), - selection = "min_fbeta" + selection = "minFbeta" ) expect_equal(length(call_log$calls), 2L) expect_equal(call_log$calls[[1]]$n, 100) @@ -119,7 +119,7 @@ test_that("lassosumRssWeights defaults to LD-quadratic selection", { expect_equal(c(result), expected) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), - "ld_quadratic" + "ldQuadratic" ) }) @@ -142,7 +142,7 @@ test_that("lassosumRssWeights uses first-max tie behavior for LD-quadratic selec expect_equal(c(result), c(1, 0, 0)) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), - "ld_quadratic" + "ldQuadratic" ) }) @@ -166,12 +166,12 @@ test_that("lassosumRssWeights still supports explicit min(fbeta)", { stat = stat, LD = R, s = 0.5, - selection = "min_fbeta" + selection = "minFbeta" ) expect_equal(c(result), expected) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), - "min_fbeta" + "minFbeta" ) }) diff --git a/tests/testthat/test_rrLassosum.R b/tests/testthat/test_rrLassosum.R index b9eb6009..dd4b226e 100644 --- a/tests/testthat/test_rrLassosum.R +++ b/tests/testthat/test_rrLassosum.R @@ -79,7 +79,7 @@ test_that("lassosumRssWeights calls lassosumRss and returns betaEst", { expect_equal(c(result), expected) expect_equal( unname(attr(result, "lassosum_selection")["mode"]), - "ld_quadratic" + "ldQuadratic" ) }) @@ -106,7 +106,7 @@ test_that("lassosumRssWeights clamps correlation input before scaling", { stat = stat, LD = R, s = 0.5, - selection = "min_fbeta" + selection = "minFbeta" ) scaled_cor <- captured / sqrt(n) expect_true(max(abs(scaled_cor)) < 1) diff --git a/tests/testthat/test_rrMrAshRss.R b/tests/testthat/test_rrMrAshRss.R index 40e26a3e..0c7d9eb6 100644 --- a/tests/testthat/test_rrMrAshRss.R +++ b/tests/testthat/test_rrMrAshRss.R @@ -1,10 +1,10 @@ context("regularized_regression - mr_ash_rss") # ============================================================================ -# mrAshRssWeights - dispatch + smoke test +# mrashRssWeights - dispatch + smoke test # ============================================================================ -test_that("mrAshRssWeights forwards arguments to susieR::mr.ash.rss", { +test_that("mrashRssWeights forwards arguments to susieR::mr.ash.rss", { set.seed(42) p <- 10 bhat <- rnorm(p, sd = 0.1) @@ -46,7 +46,7 @@ test_that("mrAshRssWeights forwards arguments to susieR::mr.ash.rss", { list(mu1 = seq_len(length(bhat)) * 0.01) } ) - result <- mrAshRssWeights( + result <- mrashRssWeights( stat = stat, LD = R, varY = 1.5, @@ -69,7 +69,7 @@ test_that("mrAshRssWeights forwards arguments to susieR::mr.ash.rss", { expect_equal(result, seq_len(p) * 0.01) }) -test_that("mrAshRssWeights returns a numeric vector of expected length", { +test_that("mrashRssWeights returns a numeric vector of expected length", { skip_if_not_installed("susieR") set.seed(2024) n <- 500 @@ -82,7 +82,7 @@ test_that("mrAshRssWeights returns a numeric vector of expected length", { shat <- rep(1 / sqrt(n - 1), p) R <- cor(X) stat <- list(b = bhat, seb = shat, n = rep(n, p)) - w <- mrAshRssWeights( + w <- mrashRssWeights( stat = stat, LD = R, varY = var(y), diff --git a/tests/testthat/test_sldscPostprocessingPipeline.R b/tests/testthat/test_sldscPostprocessingPipeline.R index ca0252ab..ba7fa176 100644 --- a/tests/testthat/test_sldscPostprocessingPipeline.R +++ b/tests/testthat/test_sldscPostprocessingPipeline.R @@ -34,6 +34,28 @@ test_that("pipeline runs end-to-end on a single + joint SldscData", { expect_true("baselineLD_0" %in% res$params$baseline_categories) }) +# The shape assertions above pass even when every meta row is NA, which is +# what a degenerate per-block tau (constant tauBlocks -> jackknife SE of 0) +# produces: metafor gets zero-variance inputs and DerSimonian-Laird drops +# every trait, leaving nTraits == 0. Assert on the values, not just the +# columns. +test_that("meta tables pool every trait rather than dropping them", { + sd <- .sldscMkData() + res <- suppressMessages(sldscPostprocessingPipeline(sd, mafCutoff = 0.05)) + + for (tbl in c("tauStar", "enrichment", "enrichstat")) { + meta <- res$meta[[tbl]] + expect_equal(meta$nTraits, rep(2L, nrow(meta)), info = tbl) + expect_false(any(is.na(meta$singleMean)), info = tbl) + expect_true(all(is.finite(meta$singleSe)), info = tbl) + expect_true(all(meta$singleSe > 0), info = tbl) + } + # tau* is the one pooled from the jackknife blocks, so it is the column + # a zero-variance tauBlocks silently empties. + expect_true(all(res$meta$tauStar$singleMean > 0)) + expect_false(any(is.na(res$meta$tauStar$jointMean))) +}) + test_that("pipeline without joint runs yields NA joint meta", { sd <- .sldscMkData(withJoint = FALSE) res <- suppressMessages(sldscPostprocessingPipeline( @@ -253,3 +275,52 @@ test_that("pipeline warns and skips a joint run that fails to standardize", { # the single side still produced an estimate expect_false(is.na(res$per_trait$traitX$summary$tauStarSingle[1])) }) + + +test_that("target stats default every annotation to non-binary", { + # With no binary flags supplied, nothing is treated as binary rather than + # the flags being dropped -- enrichment needs one entry per target. + sd <- set_names(c(1, 2), c("t1", "t2")) + out <- pecotmr:::.sldscTargetStats(sd, logical(0), c("t1", "t2")) + expect_equal(unname(out$isBinary), c(FALSE, FALSE)) + expect_equal(names(out$isBinary), c("t1", "t2")) + # Supplied flags are subset to the targets. + out2 <- pecotmr:::.sldscTargetStats( + sd, + set_names(c(TRUE, FALSE), c("t1", "t2")), + "t1" + ) + expect_true(unname(out2$isBinary)) +}) + +test_that(".sldscCollectSingle returns empty parts for no standardizations", { + out <- pecotmr:::.sldscCollectSingle(list()) + expect_null(out$singleDf) + expect_null(out$blocksSingle) + expect_length(out$singleH2gs, 0L) +}) + +test_that(".sldscTraitSingle tolerates a trait with no single-mode runs", { + local_mocked_bindings( + getTraitRun = function(...) NULL, + .package = "pecotmr" + ) + ctx <- list(sldscData = NULL, targetCategories = c("t1", "t2")) + out <- pecotmr:::.sldscTraitSingle("tr", ctx) + # NULL becomes an empty list so the min() below it stays well-defined. + expect_setequal(names(out), c("singleDf", "blocksSingle", "singleH2gs")) + expect_null(out$singleDf) +}) + +test_that(".sldscFallbackMessage says '(none)' with no baseline categories", { + expect_message( + pecotmr:::.sldscFallbackMessage( + list(categories = c("a", "b")), + oldNames = "x", + targetCategories = "a", + nTarget = 1L, + nBaseline = 0L + ), + "baseline \\(0\\): \\(none\\)" + ) +}) diff --git a/tests/testthat/test_sldscWrapper.R b/tests/testthat/test_sldscWrapper.R index bdf4bbb9..a9fe37eb 100644 --- a/tests/testthat/test_sldscWrapper.R +++ b/tests/testthat/test_sldscWrapper.R @@ -154,6 +154,24 @@ test_that("readSldscFrq errors on missing dir / no files", { expect_error(readSldscFrq(empty), "no .frq") }) +# PLINK writes .frq space-aligned rather than delimited. A delimiter-guessing +# reader parses the padding as empty fields and shifts every column left (CHR +# and SNP silently all-NA, MAF picking up NCHROBS), which then empties the +# annot join and takes computeSldscAnnotSd to zero degrees of freedom. The +# generated fixtures above are tab-delimited, so only a real PLINK file +# catches it. +test_that("readSldscFrq parses a space-aligned PLINK .frq", { + dir <- system.file("extdata", "sldsc", package = "pecotmr") + df <- readSldscFrq(dir, plinkName = "reference.") + expect_equal(nrow(df), 343L) + expect_false(any(is.na(df$SNP))) + expect_false(any(is.na(df$CHR))) + expect_true(is.numeric(df$MAF)) + expect_true(all(df$MAF >= 0 & df$MAF <= 0.5)) + expect_equal(df$SNP[[1]], "rs10865542") + expect_equal(df$MAF[[1]], 0.1656, tolerance = 1e-6) +}) + # ============================================================================= # computeSldscAnnotSd (operates on SldscData) @@ -832,3 +850,35 @@ test_that(".sldscViewForMeta returns NULL when no matching columns", { view <- fn(per_trait, "single") expect_null(view$traitX) }) + + +test_that("a constant annotation column contributes no variance", { + # var() of a constant is 0 and of an all-NA column is NA; both must come + # back as 0 so the column simply drops out of the weighted sum rather + # than poisoning it with NA. + f <- pecotmr:::.sldscColVarContrib + expect_equal(f("a", data.frame(a = c(1, 1, 1)), 2), 0) + expect_equal(f("a", data.frame(a = c(NA_real_, NA_real_)), 2), 0) + expect_equal(f("a", data.frame(a = c(1, 2, 3)), 2), 2) +}) + +test_that("readSldscAnnot accepts annotCols by position", { + dir <- withr::local_tempdir() + for (chr in 1:2) { + .make_annot_gz(dir, chr) + } + # A numeric annotCols indexes into the DETECTED columns, so 1 is the + # first annotation rather than the first column of the file. + one <- readSldscAnnot(dir, annotCols = 1L) + expect_true(is_in("annot_A", names(one))) + expect_false(is_in("annot_B", names(one))) + both <- readSldscAnnot(dir, annotCols = c(1L, 2L)) + expect_true(all(is_in(c("annot_A", "annot_B"), names(both)))) +}) + +test_that("sldscSubsetMeta requires a per_trait element", { + expect_error( + sldscSubsetMeta(list(other = 1), subsetTraits = "t1"), + "has no `per_trait` element" + ) +}) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 9d24f3e3..7ef51e75 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -7189,7 +7189,7 @@ test_that("dentistSingleWindow: rsq warning on a near-singular LD block", { test_that("harmonizeAlleles renames an empty target column to unnamed_N", { # 5 columns whose first four are positional (NOT literally named - # chrom/pos/A2/A1), so harmonizeAlleles routes through variantIdToDf -- which + # chrom/pos/A2/A1), so harmonizeAlleles routes through parseVariantId -- which # preserves the extra column -- rather than the select()-based path. The 5th # column has an empty name, so the joined matchResult carries an empty-named # column and sanitizeNames() rewrites it to "unnamed_1" (sumstatsQc.R:83). diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 2ab70715..16ff494a 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -491,3 +491,140 @@ test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPo 0L ) }) + + +test_that("an exemplar column absent from every part is NULL", { + # Callers draw the name from allCols so in practice some part has it; the + # fallthrough is the honest answer when none does, not an error. + expect_null(pecotmr:::.exemplarColumn("nosuchcol", list())) +}) + + +# =========================================================================== +# Combining collections: QC records and chromosome-path unions +# =========================================================================== + +test_that("combining inputs that carry no QC record yields an empty audit", { + # Empty, not a fabricated record: claiming QC that never ran would be + # worse than reporting none. + expect_equal(pecotmr:::.ssCombineQcInfo(list(), "combineX"), list()) +}) + +test_that("chromosome paths union when they agree and abort when they clash", { + # A sharded sketch routes a row to its file by CHR, so one chromosome + # mapping to two files means the parts are not the same panel at all. + mk <- function(paths) { + new( + "GenotypeHandle", + path = "/tmp/x.gds", + format = "gds", + snpInfo = data.frame( + SNP = "a", + CHR = "1", + BP = 1L, + A1 = "A", + A2 = "G", + fileIdx = 1L, + stringsAsFactors = FALSE + ), + nSamples = 1L, + sampleIds = "s1", + pgenPtr = NULL, + chromPaths = paths + ) + } + h1 <- mk(c("1" = "/data/chr1.pgen")) + h2 <- mk(c("1" = "/data/chr1.pgen", "2" = "/data/chr2.pgen")) + out <- pecotmr:::.ssUnionChromPaths(list(h1, h2), "combineX") + expect_equal(sort(names(out)), c("1", "2")) + expect_equal(unname(out[["1"]]), "/data/chr1.pgen") + # Same chromosome, different file -> refused. + h3 <- mk(c("1" = "/other/chr1.pgen")) + expect_error( + pecotmr:::.ssUnionChromPaths(list(h1, h3), "combineX"), + "chromosome '1' maps to two different genotype" + ) +}) + + +# =========================================================================== +# Row-payload coercion and unmerged collection slots +# =========================================================================== + +test_that("an empty collection coerces to itself, not to a row", { + # getFineMappingResult() hands over a single-row COLLECTION, so the + # coercion has to accept that shape -- but an empty one has no row to + # extract and must come back untouched. + data(qtlFineMappingExample, twasWeightsExample) + expect_s4_class( + pecotmr:::.asFmRowPayload(qtlFineMappingExample[0]), + "QtlFineMappingResult" + ) + expect_s4_class( + pecotmr:::.asTwRowPayload(twasWeightsExample[0]), + "TwasWeights" + ) + # A populated one becomes the row payload. + expect_s4_class( + pecotmr:::.asFmRowPayload(qtlFineMappingExample), + "FineMappingRow" + ) + expect_s4_class( + pecotmr:::.asTwRowPayload(twasWeightsExample), + "TwasWeightsRow" + ) + # Anything that is not a collection passes straight through. + expect_equal(pecotmr:::.asFmRowPayload(42), 42) + expect_equal(pecotmr:::.asTwRowPayload("x"), "x") +}) + +test_that("a collection-level slot with no merge rule is refused", { + # Silently dropping a slot when combining would lose provenance, so an + # unrecognised one is an error naming the slot(s) and the class. + setClass( + "TsExtraKid", + contains = "RangedTupleList", + representation( + genome = "character", + ldSketch = "ANY", + surprise = "character" + ) + ) + k <- new( + "TsExtraKid", + GenomicRanges::GRangesList( + a = GenomicRanges::GRanges("chr1", IRanges::IRanges(1L, width = 1L)) + ), + genome = "hg38", + ldSketch = NULL, + surprise = "boo" + ) + expect_error( + pecotmr:::.rtlExtraSlots(list(k, k), "combineX"), + "no merge rule for the collection-level slot" + ) + # The message names the offending slots and the class. + expect_error( + pecotmr:::.rtlExtraSlots(list(k, k), "combineX"), + "surprise" + ) +}) + +test_that(".twrRowResolveWeights drops rows whose weights are all NA", { + allNa <- twasWeightsRow( + variantIds = c("chr1:1:A:G", "chr1:2:C:T"), + weights = c(NA_real_, NA_real_) + ) + out <- pecotmr:::.twrRowResolveWeights(allNa) + # Nothing usable survives, so the row contributes no variants at all. + expect_length(out$variantIds, 0L) + expect_length(out$weights, 0L) + # Control: a single usable weight is kept, and only that one. + partial <- twasWeightsRow( + variantIds = c("chr1:1:A:G", "chr1:2:C:T"), + weights = c(NA_real_, 0.5) + ) + kept <- pecotmr:::.twrRowResolveWeights(partial) + expect_equal(kept$variantIds, "chr1:2:C:T") + expect_equal(kept$weights, 0.5) +}) diff --git a/tests/testthat/test_twasWeights.R b/tests/testthat/test_twasWeights.R index cd50e12a..ca88040b 100644 --- a/tests/testthat/test_twasWeights.R +++ b/tests/testthat/test_twasWeights.R @@ -109,7 +109,7 @@ test_that(".twas_method_lookup: 'default' preset returns 10 methods", { }) test_that(".twas_method_lookup: 'fast_default' preset returns 8 methods", { - result <- pecotmr:::.twasMethodLookup("fast_default") + result <- pecotmr:::.twasMethodLookup("fastDefault") expected_names <- c( "susie_weights", "susie_inf_weights", @@ -124,7 +124,7 @@ test_that(".twas_method_lookup: 'fast_default' preset returns 8 methods", { }) test_that(".twas_method_lookup: custom vector of short names", { - result <- pecotmr:::.twasMethodLookup(c("susie", "enet", "dpr_vb")) + result <- pecotmr:::.twasMethodLookup(c("susie", "enet", "dprVb")) expect_equal( sort(names(result)), sort(c("susie_weights", "enet_weights", "dpr_vb_weights")) @@ -134,12 +134,12 @@ test_that(".twas_method_lookup: custom vector of short names", { test_that(".twas_method_lookup: unknown method produces error", { expect_error( pecotmr:::.twasMethodLookup(c("susie", "nonexistent_method")), - "Unknown TWAS method" + "unknown method token" ) }) test_that(".twas_method_lookup: default args are set for susie and mrash", { - result <- pecotmr:::.twasMethodLookup("fast_default") + result <- pecotmr:::.twasMethodLookup("fastDefault") expect_equal(result$susie_weights$refine, FALSE) # Matches susieR::susie's own defaults (L = min(10, p), greedy loop off), # as fineMappingPipeline does. @@ -157,9 +157,9 @@ test_that(".twas_method_lookup: methods with no special args get empty list", { test_that(".twas_method_lookup: all DPR variants can coexist", { result <- pecotmr:::.twasMethodLookup(c( - "dpr_vb", - "dpr_gibbs", - "dpr_adaptive_gibbs" + "dprVb", + "dprGibbs", + "dprAdaptiveGibbs" )) expect_equal( sort(names(result)), @@ -1619,3 +1619,95 @@ test_that("twasPredict: accepts a TwasWeights S4 collection", { expect_equal(res[["lasso_predicted"]], X %*% matrix(w1, ncol = 1)) expect_equal(res[["enet_predicted"]], X %*% matrix(w2, ncol = 1)) }) + + +# =========================================================================== +# TwasWeights validity and variant identity +# =========================================================================== + +test_that("validity names the missing key and payload columns", { + data(twasWeightsExample) + bad <- twasWeightsExample + S4Vectors::mcols(bad)$method <- NULL + expect_equal( + pecotmr:::.twasValidateRequiredCols(bad), + "missing columns: method" + ) + expect_equal( + pecotmr:::.twasValidateRequiredCols(twasWeightsExample), + character() + ) + bad2 <- twasWeightsExample + S4Vectors::mcols(bad2)$cvResult <- NULL + expect_equal( + pecotmr:::.twasValidateEntries(bad2), + "missing entry payload columns: cvResult" + ) +}) + +test_that("an unnamed genotype matrix is refused rather than given fake ids", { + # A synthetic "variant_" label would not create identity, only defer + # the failure to wherever the genomic range is needed. + X <- matrix(1:4, 2L, 2L) + expect_error( + pecotmr:::.twasVariantIds(X), + "the genotype matrix has no colnames" + ) + colnames(X) <- c("chr1:1:A:G", "chr1:2:C:T") + expect_equal(pecotmr:::.twasVariantIds(X), c("chr1:1:A:G", "chr1:2:C:T")) +}) + +test_that(".twasApplyRownames leaves weights alone when X has no colnames", { + weightsList <- list(a = matrix(1:4, nrow = 2L)) + noNames <- matrix(0, nrow = 3L, ncol = 2L) + # Without variant names on X there is nothing to label the rows with. + expect_identical( + pecotmr:::.twasApplyRownames(weightsList, noNames), + weightsList + ) + named <- noNames + colnames(named) <- c("v1", "v2") + out <- pecotmr:::.twasApplyRownames(weightsList, named) + expect_equal(rownames(out$a), c("v1", "v2")) +}) + +test_that(".twasBadColMsg names the offending column and its class", { + expect_equal( + as.character(pecotmr:::.twasBadColMsg("study", data.frame(study = 1:2))), + "'study' column must be character (got integer)" + ) +}) + +test_that(".twasMethodRows keeps a per-outcome context vector", { + vids <- c("chr1:100:A:G", "chr1:200:C:T") + Y <- matrix(0, nrow = 4L, ncol = 2L, + dimnames = list(NULL, c("y1", "y2"))) + wMat <- matrix( + c(0.1, 0.2, 0.3, 0.4), + nrow = 2L, + dimnames = list(vids, c("y1", "y2")) + ) + mkCtx <- function(contexts) { + list( + Y = Y, trait = c("t1", "t2"), context = contexts, study = "s1", + retainFits = FALSE, standardized = TRUE, dataType = "rnaseq" + ) + } + # One context per outcome column: used as-is, not recycled. + perOutcome <- pecotmr:::.twasMethodRows( + "lasso_weights", wMat, vids, mkCtx(c("cA", "cB")) + ) + expect_length(perOutcome, 2L) + expect_equal( + vapply(perOutcome, function(z) z$context, character(1)), + c("cA", "cB") + ) + # A single context is recycled across the outcomes instead. + recycled <- pecotmr:::.twasMethodRows( + "lasso_weights", wMat, vids, mkCtx("cOnly") + ) + expect_equal( + vapply(recycled, function(z) z$context, character(1)), + c("cOnly", "cOnly") + ) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 17b8c9a6..7f7d0604 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -8,7 +8,7 @@ context("twasWeightsPipeline (S4 dispatch) with mocked weight methods") # CV bookkeeping, ensemble fan-in, and packaging results into a TwasWeights # collection. The actual weight learners are external and slow. We mock the # weight functions (lassoWeights / enetWeights / susieWeights, plus the -# RSS-side susieRssWeights / lassosumRssWeights / mrAshRssWeights) to return +# RSS-side susieRssWeights / lassosumRssWeights / mrashRssWeights) to return # zero-valued vectors / matrices so the orchestration runs end-to-end on a # small fixture. # =========================================================================== @@ -396,7 +396,7 @@ test_that("twasWeightsPipeline(QtlDataset): RSS-only method rejected", { list( susieRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), lassosumRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), - mrAshRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), + mrashRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), susieInfRssWeights = function(stat, LD, ...) rep(0, nrow(LD)), sdprWeights = function(stat, LD, ...) rep(0, nrow(LD)) ) @@ -579,7 +579,7 @@ test_that("gate: unknown method tokens still error with full menu", { qd <- .tp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") expect_error( twasWeightsPipeline(qd, methods = "totallyMadeUpMethod"), - "Unknown TWAS method|unknown method" + "unknown method token" ) }) @@ -1126,19 +1126,67 @@ test_that("twasWeightsPipeline(ANY): unsupported input class errors", { # twasMultivariateWeightsPipeline # =========================================================================== -# NOTE: twasMultivariateWeightsPipeline currently bottoms out on a -# `getWeights(twasWeight)` call (R/twasWeights.R:2105) that omits the -# (study, context, trait, method) selectors and therefore errors whenever -# the inner learnTwasWeights() returns a collection with >1 row — which it -# always does when both mr.mash and mvSuSiE are requested (the default). -# Skipping this test until that path is reworked to walk all rows; flagging -# here so coverage doesn't appear lifted on a known-broken pipeline. -test_that("twasMultivariateWeightsPipeline: known-broken under the new TwasWeights API", { - skip( - "twasMultivariateWeightsPipeline calls getWeights() on a multi-row TwasWeights without selectors; needs a follow-up fix in production code." +# twasMultivariateWeightsPipeline() was a deprecation stub and was removed in +# 2be68392; its documented replacement is twasWeightsPipeline() with both +# multivariate tokens passed together. That migration path is what is tested +# here -- the two solvers must fit side by side and partition their output by +# (study, context, trait, method) rather than collide. + +test_that("twasWeightsPipeline: mr.mash and mvSuSiE fit side by side", { + qd <- .tp_makeQtlDataset( + contexts = c("brain", "liver"), + traits = c("ENSG_A", "ENSG_B") + ) + fmr <- .tp_makeStubFineMappingResult( + study = "study1", + contexts = c("brain", "liver"), + traits = c("ENSG_A", "ENSG_B"), + method = "mvsusie" ) + mvCalls <- 0L + mrCalls <- 0L + mkW <- function(X, Y) { + matrix( + 0, + nrow = ncol(X), + ncol = ncol(Y), + dimnames = list(colnames(X), colnames(Y)) + ) + } + mocks <- list( + extractBlockGenotypes = .tp_mockExtractor(), + mvsusieWeights = function(X, Y, mvsusieFit = NULL, ...) { + mvCalls <<- mvCalls + 1L + mkW(X, Y) + }, + mrmashWeights = function(X, Y, ...) { + mrCalls <<- mrCalls + 1L + mkW(X, Y) + } + ) + do.call(local_mocked_bindings, c(mocks, list(.package = "pecotmr"))) + res <- suppressMessages(suppressWarnings( + twasWeightsPipeline( + qd, + methods = c("mrmash", "mvsusie"), + fineMappingResult = fmr, + cisWindow = 1000L, + cvFolds = 0, + ensemble = FALSE, + estimatePi = FALSE, + verbose = 0 + ) + )) + expect_s4_class(res, "TwasWeights") + # Both solvers ran, and each contributes its own rows. + expect_gte(mvCalls, 1L) + expect_gte(mrCalls, 1L) + expect_setequal(getMethodNames(res), c("mrmash", "mvsusie")) + expect_setequal(getContexts(res), c("brain", "liver")) + expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) + # 2 contexts x 2 traits x 2 methods, with no method overwriting the other. + expect_equal(nrow(res), 8L) }) - # imputeMissingGwasForSketch was removed: it duplicated the inline RAISS # imputation step at the bottom of .runEntrySummaryStatsQc (sumstatsQc.R), # had no production callers, and was orphaned post-S4-refactor. The RAISS- @@ -1671,8 +1719,8 @@ test_that(".twasNormalizeMethods: NULL falls through to the 'default' preset", { }) test_that(".twasNormalizeMethods: character preset string forwards to .twasMethodLookup", { - res <- pecotmr:::.twasNormalizeMethods("fast_default") - fast_names <- names(pecotmr:::.twasMethodLookup("fast_default")) + res <- pecotmr:::.twasNormalizeMethods("fastDefault") + fast_names <- names(pecotmr:::.twasMethodLookup("fastDefault")) expect_equal(sort(names(res$methodList)), sort(fast_names)) }) @@ -1862,7 +1910,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { }) # =========================================================================== -# getSumstatDf (public method on GwasSumStats / QtlSumStats; replaces +# getSumStatsDf (public method on GwasSumStats / QtlSumStats; replaces # the now-deleted `.twasSumstatsEntryToDf` shim) # =========================================================================== @@ -1903,7 +1951,7 @@ test_that(".twasAssertQcd: passes when qcInfo is populated", { ) } -test_that("getSumstatDf: returns the canonical column layout", { +test_that("getSumStatsDf: returns the canonical column layout", { ss <- .gsd_makeGwasSumStats(data.frame( SNP = c("rs1", "rs2"), A1 = c("A", "A"), @@ -1912,7 +1960,7 @@ test_that("getSumstatDf: returns the canonical column layout", { N = c(1000L, 1500L), MAF = c(0.1, 0.3) )) - df <- getSumstatDf(ss) + df <- getSumStatsDf(ss) expect_s3_class(df, "data.frame") expect_equal(df$variant_id, c("rs1", "rs2")) expect_equal(df$chrom, c("chr1", "chr1")) @@ -1922,7 +1970,7 @@ test_that("getSumstatDf: returns the canonical column layout", { expect_equal(df$maf, c(0.1, 0.3)) }) -test_that("getSumstatDf: derives z from beta/se when derive='zFromBetaSe'", { +test_that("getSumStatsDf: derives z from beta/se when derive='zFromBetaSe'", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -1934,13 +1982,13 @@ test_that("getSumstatDf: derives z from beta/se when derive='zFromBetaSe'", { ), snp_n = 1L ) - df <- getSumstatDf(ss, derive = "zFromBetaSe") + df <- getSumStatsDf(ss, derive = "zFromBetaSe") expect_equal(df$beta, 0.5) expect_equal(df$se, 0.1) expect_equal(df$z, 0.5 / 0.1) }) -test_that("getSumstatDf: omits optional columns when absent", { +test_that("getSumStatsDf: omits optional columns when absent", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -1949,7 +1997,7 @@ test_that("getSumstatDf: omits optional columns when absent", { ), snp_n = 1L ) - df <- getSumstatDf(ss) + df <- getSumStatsDf(ss) expect_false("z" %in% names(df)) expect_false("beta" %in% names(df)) expect_false("se" %in% names(df)) @@ -1957,7 +2005,7 @@ test_that("getSumstatDf: omits optional columns when absent", { expect_false("maf" %in% names(df)) }) -test_that("getSumstatDf: require=c('Z','N') errors when columns missing", { +test_that("getSumStatsDf: require=c('Z','N') errors when columns missing", { ss <- .gsd_makeGwasSumStats( data.frame( SNP = "rs1", @@ -1967,7 +2015,7 @@ test_that("getSumstatDf: require=c('Z','N') errors when columns missing", { ), snp_n = 1L ) - expect_error(getSumstatDf(ss, require = c("Z", "N")), "no N mcol") + expect_error(getSumStatsDf(ss, require = c("Z", "N")), "no N mcol") }) # =========================================================================== @@ -2220,6 +2268,86 @@ test_that(".twasMergeRegionEntries returns a single entry unchanged", { ) }) +test_that(".twasMergeRegionEntries rbinds matrix weights across regions", { + mk <- function(vids, w) { + twasWeightsRow(variantIds = vids, weights = w) + } + m1 <- matrix( + c(0.1, 0.2, 0.3, 0.4), + nrow = 2L, + dimnames = list(c("chr1:100:A:G", "chr1:200:A:G"), c("cA", "cB")) + ) + m2 <- matrix( + c(0.5, 0.6, 0.7, 0.8), + nrow = 2L, + dimnames = list(c("chr1:300:A:G", "chr1:400:A:G"), c("cA", "cB")) + ) + m <- pecotmr:::.twasMergeRegionEntries( + list(mk(rownames(m1), m1), mk(rownames(m2), m2)), + c("r1", "r2") + ) + w <- getWeights(m) + # Matrix weights stack by ROW -- one row per variant, contexts preserved + # as columns. The vector branch would have flattened this to length 8. + expect_true(is.matrix(w)) + expect_equal(dim(w), c(4L, 2L)) + expect_equal(colnames(w), c("cA", "cB")) + expect_equal(rownames(w), c( + "chr1:100:A:G", "chr1:200:A:G", + "chr1:300:A:G", "chr1:400:A:G" + )) + expect_equal(unname(w[, "cA"]), c(0.1, 0.2, 0.5, 0.6)) + expect_equal(unname(w[, "cB"]), c(0.3, 0.4, 0.7, 0.8)) + expect_equal(names(getFits(m)), c("r1", "r2")) +}) + +test_that(".twasNormalizeCharMethods: fine-mapping-only tokens skip lookup", { + # `ser` and `fsusie` are fine-mapping tokens with no weight extractor in + # the method table, so `regular` is empty and the lookup is never called. + res <- pecotmr:::.twasNormalizeCharMethods(c("ser", "fsusie")) + expect_equal(res$tokens, c("ser", "fsusie")) + expect_equal( + sort(names(res$methodList)), + c("fsusie_weights", "ser_weights") + ) + expect_equal(res$methodList[["ser_weights"]], list()) + expect_equal(res$methodList[["fsusie_weights"]], list()) +}) + +test_that(".twasMergedEntryForRow gathers one key across regions", { + data(twasWeightsExample) + tw <- twasWeightsExample + base <- data.frame( + study = as.character(tw$study), + context = as.character(tw$context), + trait = as.character(tw$trait), + method = as.character(tw$method), + stringsAsFactors = FALSE + ) + m <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw, tw), c("rA", "rB")) + expect_s4_class(m, "TwasWeightsRow") + expect_equal(names(getFits(m)), c("rA", "rB")) + # Same table twice: the merged entry carries both regions' variants. + one <- pecotmr:::.twasMergedEntryForRow(1L, base, list(tw), "rA") + expect_equal( + length(pecotmr:::.twrPartsVariantIds(m)), + 2L * length(pecotmr:::.twrPartsVariantIds(one)) + ) +}) + +test_that(".twasMergedEntryForRow returns NULL when no region matches", { + data(twasWeightsExample) + bad <- data.frame( + study = "nope", context = "x", trait = "y", method = "z", + stringsAsFactors = FALSE + ) + expect_null( + pecotmr:::.twasMergedEntryForRow( + 1L, bad, list(twasWeightsExample), "rA" + ) + ) +}) + test_that("twasWeightsPipeline(QtlDataset): region + cisWindow is rejected", { qd <- .tp_makeQtlDataset(traits = "ENSG_A") expect_error( @@ -2964,7 +3092,7 @@ test_that("twasWeightsPipeline(QtlSumStats): NULL methods uses the default RSS p twasWeightsPipeline(ss, methods = NULL, verbose = 0) )) expect_s4_class(res, "TwasWeights") - expect_setequal(getMethodNames(res), c("lasso", "prsCs", "dpr_gibbs")) + expect_setequal(getMethodNames(res), c("lasso", "prsCs", "dprGibbs")) }) test_that("twasWeightsPipeline(QtlSumStats): named-list methods and invalid type", { @@ -3267,7 +3395,7 @@ test_that("twasWeightsPipeline(QtlSumStats): a mismatched SNP order in a multiva ss <- .tp_makeQtlSumStats(n_entries = 2L) # (s1, t1) x 2 ctx calls <- 0L local_mocked_bindings( - getSumstatDf = function(x, study, context, trait, require, ...) { + getSumStatsDf = function(x, study, context, trait, require, ...) { calls <<- calls + 1L vid <- if (calls == 1L) { c("chr1:100:A:G", "chr1:200:A:G") @@ -3409,6 +3537,96 @@ test_that(".solveEnsembleGlmnet: solver failure falls back to equal weights", { expect_equal(z, c(0.5, 0.5)) }) +test_that(".solveEnsembleGlmnet: all-zero fit falls back to equal weights", { + skip_if_not_installed("glmnet") + # `lower.limits = 0` forbids negative coefficients, so a strictly + # NEGATIVE predictor/outcome relation drives every coefficient to zero + # at any lambda -- deterministic without seeding the CV folds. + n <- 60L + x1 <- seq_len(n) / n + P <- cbind(x1, x1^2, sqrt(x1)) + y <- -x1 + expect_warning( + z <- pecotmr:::.solveEnsembleGlmnet(P, y, 3L), + "all-zero solution" + ) + expect_equal(z, rep(1 / 3, 3L)) +}) + +test_that(".ensembleBuildPd accepts vector predictions", { + nm <- list( + predNames = c("aPredicted", "bPredicted"), + baseNames = c("a", "b"), + K = 2L + ) + aln <- list(yD = c(1, 2, 3, 4), predOrder = 1:4, nD = 4L) + predsD <- list(aPredicted = c(1, 2, 3, 4), bPredicted = c(5, 6, 7, 8)) + Pd <- pecotmr:::.ensembleBuildPd(predsD, nm, aln, contextIndex = 1L, d = 1L) + # A plain vector takes the non-matrix branch: no context column to pick. + expect_equal(dim(Pd), c(4L, 2L)) + expect_equal(colnames(Pd), c("a", "b")) + expect_equal(unname(Pd[, "a"]), c(1, 2, 3, 4)) + expect_equal(unname(Pd[, "b"]), c(5, 6, 7, 8)) +}) + +test_that(".ensembleBuildPd errors when prediction length misaligns", { + nm <- list( + predNames = c("aPredicted", "bPredicted"), + baseNames = c("a", "b"), + K = 2L + ) + # predOrder selects 3 rows but the alignment claims 5 samples. + aln <- list(yD = c(1, 2, 3, 4, 5), predOrder = 1:3, nD = 5L) + predsD <- list(aPredicted = c(1, 2, 3, 4), bPredicted = c(5, 6, 7, 8)) + expect_error( + pecotmr:::.ensembleBuildPd(predsD, nm, aln, 1L, 7L), + "Prediction length for method 'aPredicted' in dataset 7" + ) +}) + +test_that(".ensembleAccumulateWeights returns a matrix for multi-context", { + w1 <- matrix( + c(1, 2, 3, 4), + nrow = 2L, + dimnames = list(c("v1", "v2"), c("c1", "c2")) + ) + w2 <- matrix( + c(5, 6, 7, 8), + nrow = 2L, + dimnames = list(c("v1", "v2"), c("c1", "c2")) + ) + out <- pecotmr:::.ensembleAccumulateWeights( + list(a_weights = w1, b_weights = w2), + c("a_weights", "b_weights"), + c(TRUE, TRUE), + c(0.25, 0.75) + ) + # Two columns, so the univariate vector shortcut must NOT fire. + expect_true(is.matrix(out)) + expect_equal(dim(out), c(2L, 2L)) + expect_equal(dimnames(out), list(c("v1", "v2"), c("c1", "c2"))) + expect_equal(out, 0.25 * w1 + 0.75 * w2) +}) + +test_that(".ensembleAccumulateWeights skips a dim-mismatched member", { + w1 <- matrix( + c(1, 2, 3, 4), + nrow = 2L, + dimnames = list(c("v1", "v2"), c("c1", "c2")) + ) + expect_warning( + out <- pecotmr:::.ensembleAccumulateWeights( + list(a_weights = w1, b_weights = matrix(1:6, nrow = 3L)), + c("a_weights", "b_weights"), + c(TRUE, TRUE), + c(0.5, 0.5) + ), + "inconsistent dimensions" + ) + # Only the conforming member contributes; its zeta is NOT renormalized. + expect_equal(out, 0.5 * w1) +}) + # --------------------------------------------------------------------------- # RSS panel filters on QtlSumStats input. @@ -3449,7 +3667,7 @@ test_that("twasWeightsPipeline RSS cutoffs match .panelVariantFilter", { # Exactly the variants the shared filter names: no more (something else is # filtering) and no fewer (the cutoff silently did nothing). ss <- .twrssf_qcd() - ids <- getSumstatDf( + ids <- getSumStatsDf( ss, study = ss$study[[1L]], context = ss$context[[1L]], @@ -3504,3 +3722,228 @@ test_that(".twasQssUnivariateFitCtx keeps z, ids and LD aligned", { keep <- is_in(plain$variantIds, cut$variantIds) expect_equal(cut$stat$z, plain$stat$z[keep]) }) + + +# =========================================================================== +# Fine-mapping method resolution and per-token argument plumbing +# =========================================================================== + +test_that("no fineMappingResult means no fine-mapping methods are present", { + expect_equal( + pecotmr:::.twasFineMappingMethodsPresent(NULL), + character(0) + ) +}) + +test_that("a fine-mapping token with no weight extractor is refused", { + # susie/susieInf/susieAsh/mvsusie/fsusie have adapters; `ser` is a + # fine-mapping-only method with no weights to extract, so asking for it + # is an error rather than a silently missing row. + expect_null(pecotmr:::.twasCheckFmAdapters(character(0))) + expect_error( + pecotmr:::.twasCheckFmAdapters("ser"), + "method\\(s\\) ser have no TWAS-weight extractor" + ) +}) + +test_that("per-token user arguments default to an empty list", { + # NULL would splice as a missing argument rather than "nothing to add". + expect_equal(pecotmr:::.twasUserArgs(list(), "susie"), list()) + expect_equal( + pecotmr:::.twasUserArgs(list(susie = list(L = 5)), "susie"), + list(L = 5) + ) +}) + +test_that("a missing multivariate fit warns with the tuple that was skipped", { + expect_warning( + pecotmr:::.twasWarnNoFitMv("mvsusie", "S1", "G1"), + "no 'mvsusie' fit found in fineMappingResult" + ) +}) + + +# =========================================================================== +# The methods= argument in its three accepted shapes +# =========================================================================== + +test_that("method tokens are read from a character vector or a named list", { + # The argument reaches here as either a character vector or a list keyed + # by implementation name; both must yield the same bare tokens so the + # downstream comparisons work on one vocabulary. + f <- pecotmr:::.twasMethodTokensFromArg + expect_equal(f(c("lasso", "enet")), c("lasso", "enet")) + expect_equal( + f(list(lasso_weights = list(), enetWeights = list())), + c("lasso", "enet") + ) + # Anything else contributes no tokens rather than erroring. + expect_equal(f(42), character(0)) +}) + +test_that("mrmash is stripped from either shape, leaving others intact", { + # mrmash is dispatched by the joint path, so the per-method loop must not + # also run it -- otherwise the tuple is fitted twice. + g <- pecotmr:::.twasMsStripMrmash + expect_equal(g(c("lasso", "mrmash", "enet")), c("lasso", "enet")) + expect_equal( + names(g(list(lasso_weights = list(), mrmash_weights = list()))), + "lasso_weights" + ) + # An unrecognised shape passes through untouched. + expect_equal(g(42), 42) +}) + +test_that("a region lacking a tuple contributes no entry for it", { + # NULL, not an empty row: a region that never fitted the tuple must not + # dilute the merged weights with zeros. + data(twasWeightsExample) + tw <- twasWeightsExample + key <- c( + as.character(tw$study)[[1L]], + as.character(tw$context)[[1L]], + as.character(tw$trait)[[1L]], + as.character(tw$method)[[1L]] + ) + expect_s4_class( + pecotmr:::.twasEntryMatchingKey(tw, key), + "TwasWeightsRow" + ) + expect_null( + pecotmr:::.twasEntryMatchingKey(tw, c("nope", "x", "y", "z")) + ) +}) + + +# =========================================================================== +# Merging per-region and joint results +# =========================================================================== + +test_that("merging regions short-circuits on none and on one", { + # A single region needs no key-wise merge, and no regions is NULL rather + # than an empty collection the caller would have to special-case anyway. + data(twasWeightsExample) + expect_null(pecotmr:::.twasMergeRegionResults(list(), NULL)) + expect_identical( + pecotmr:::.twasMergeRegionResults(list(twasWeightsExample), NULL), + twasWeightsExample + ) +}) + +test_that("assembling per-tuple and joint results covers all four cases", { + # Both empty is an error -- the run produced nothing and returning an + # empty collection would look like a successful null result. + data(twasWeightsExample) + tw <- twasWeightsExample + expect_error( + pecotmr:::.twasQdsAssemble(NULL, NULL), + "no \\(context, trait\\) pair produced any weights" + ) + expect_identical(pecotmr:::.twasQdsAssemble(tw, NULL), tw) + expect_identical(pecotmr:::.twasQdsAssemble(NULL, tw), tw) +}) + +test_that("an empty methods argument is detected in either shape", { + expect_true(pecotmr:::.twasMethodsEmpty(character(0))) + expect_true(pecotmr:::.twasMethodsEmpty(list())) + expect_false(pecotmr:::.twasMethodsEmpty("lasso")) +}) + +# --------------------------------------------------------------------------- +# Multivariate skip/merge paths: a region or tuple that produces no fit must +# drop out quietly rather than contributing empty weights. +# --------------------------------------------------------------------------- + +test_that(".twasMvThreadFit warns and returns NULL when the fit is absent", { + spec <- list(adapter = list(rssFitArg = "susie_fit")) + expect_warning( + r <- pecotmr:::.twasMvThreadFit( + spec, + list(a = 1), + "mvsusie", + "S1", + "T1", + c("cA", "cB"), + list(fineMappingResult = NULL) + ), + "no 'mvsusie' fit found" + ) + expect_null(r) +}) + +test_that(".twasQssMultivariateFitOne returns no rows when the fit is absent", { + p <- list( + fineMappingResult = NULL, + methodArgs = list(), + retainFitDetail = FALSE + ) + # mvsusie carries an adapter, so the missing pre-fit short-circuits + # before any weight function is called. + expect_warning( + rows <- pecotmr:::.twasQssMultivariateFitOne( + "mvsusie", "S1", "T1", c("cA", "cB"), NULL, NULL, p + ), + "no 'mvsusie' fit found" + ) + expect_identical(rows, list()) +}) + +test_that(".twasQssMultivariateFitOne promotes vector weights to a matrix", { + mvStat <- list( + stat = NULL, + variantIds = c("chr1:1:A:G", "chr1:2:A:G") + ) + p <- list(methodArgs = list(), retainFitDetail = FALSE, dataType = "rnaseq") + local_mocked_bindings( + .twasTryWeights = function(...) c(0.5, 0.25), + .package = "pecotmr" + ) + # mrmash has no adapter, so the thread-fit branch is skipped entirely. + rows <- pecotmr:::.twasQssMultivariateFitOne( + "mrmash", "S1", "T1", "cA", mvStat, NULL, p + ) + expect_length(rows, 1L) + expect_equal(rows[[1L]]$context, "cA") + expect_equal(unname(getWeights(rows[[1L]]$entry)), c(0.5, 0.25)) +}) + +test_that(".twasQssAssemble passes the joint result through alone", { + jr <- "SENTINEL_JOINT" + expect_identical( + pecotmr:::.twasQssAssemble(list(), jr, list(ldSketch = NULL)), + jr + ) +}) + +test_that(".twasMsJointPhase aborts when only mrmash asked and it fails", { + local_mocked_bindings( + .twasDispatchJointSpecsMultiStudy = function(...) NULL, + .package = "pecotmr" + ) + p <- list( + methods = "mrmash", data = NULL, contexts = NULL, traitId = NULL, + cisWindow = NULL, verbose = FALSE, retainFit = FALSE, + retainFitDetail = FALSE, seed = 1L + ) + # Stripping mrmash leaves nothing, so a NULL joint result is fatal + # rather than a fall-through to the per-tuple phase. + expect_error( + pecotmr:::.twasMsJointPhase(p, list(spec1 = "x"), NULL), + "no joint fits produced" + ) +}) + +test_that(".twasRunMultivariateGrid returns NULL when every region is empty", { + local_mocked_bindings( + .twasMvGridRegion = function(...) NULL, + .twasRegionLabel = function(x) "rX", + .package = "pecotmr" + ) + expect_null( + pecotmr:::.twasRunMultivariateGrid( + traits = "T1", + marker = NULL, + ctx = list(xRegions = list(1, 2)) + ) + ) +}) diff --git a/tests/testthat/test_variantId.R b/tests/testthat/test_variantId.R index 0ad545f9..0838e95f 100644 --- a/tests/testthat/test_variantId.R +++ b/tests/testthat/test_variantId.R @@ -245,70 +245,6 @@ test_that("regionToDf: honours custom column names", { expect_equal(colnames(res), c("seq", "from", "to")) }) -# =========================================================================== -# regionsOverlap -# =========================================================================== - -test_that("regionsOverlap: TRUE when regions share a base pair", { - expect_true(regionsOverlap("chr1:100-200", "chr1:150-250")) - expect_true(regionsOverlap("chr1:100-200", "chr1:200-300")) # touching -}) - -test_that("regionsOverlap: FALSE when regions are disjoint", { - expect_false(regionsOverlap("chr1:100-200", "chr1:300-400")) -}) - -test_that("regionsOverlap: FALSE across different chromosomes", { - # Bioconductor warns when comparing GRanges with disjoint seqlevels — - # the semantics of "no overlap" is exactly what we want here. - expect_false(suppressWarnings(regionsOverlap( - "chr1:100-200", - "chr2:100-200" - ))) -}) - -test_that("regionsOverlap: accepts data.frame input", { - a <- data.frame( - chrom = "1", - start = 100L, - end = 200L, - stringsAsFactors = FALSE - ) - b <- data.frame( - chrom = "1", - start = 150L, - end = 300L, - stringsAsFactors = FALSE - ) - expect_true(regionsOverlap(a, b)) -}) - -# =========================================================================== -# findOverlappingRegions -# =========================================================================== - -test_that("findOverlappingRegions: returns the indices of overlapping targets", { - targets <- c("chr1:100-200", "chr1:300-400", "chr1:150-250", "chr2:100-200") - res <- findOverlappingRegions("chr1:175-225", targets) - expect_equal(sort(res), c(1L, 3L)) -}) - -test_that("findOverlappingRegions: empty result when no overlap", { - res <- findOverlappingRegions( - "chr1:500-600", - c("chr1:100-200", "chr1:300-400") - ) - expect_equal(res, integer(0)) -}) - -test_that("findOverlappingRegions: deduplicates target hits", { - res <- findOverlappingRegions( - "chr1:150-160", - c("chr1:100-200", "chr1:300-400") - ) - expect_equal(res, 1L) -}) - # =========================================================================== # classifyVariantType # =========================================================================== @@ -543,12 +479,12 @@ test_that("normalizeVariantId leaves unparseable ids (rsIDs) unchanged", { }) # ============================================================================= -# variantIdToDf +# parseVariantId — id-format coverage (was the variantIdToDf alias) # ============================================================================= -test_that("variantIdToDf handles colon-separated format", { +test_that("parseVariantId handles colon-separated format", { ids <- c("1:100:A:G", "2:200:C:T") - result <- pecotmr:::variantIdToDf(ids) + result <- parseVariantId(ids) expect_equal(nrow(result), 2) expect_equal(result$chrom, c("1", "2")) expect_equal(result$pos, c(100L, 200L)) @@ -557,37 +493,37 @@ test_that("variantIdToDf handles colon-separated format", { }) -test_that("variantIdToDf handles underscore-separated format", { +test_that("parseVariantId handles underscore-separated format", { ids <- c("1:100_A_G", "2:200_C_T") - result <- pecotmr:::variantIdToDf(ids) + result <- parseVariantId(ids) expect_equal(nrow(result), 2) expect_equal(result$A2, c("A", "C")) }) -test_that("variantIdToDf strips chr prefix", { +test_that("parseVariantId strips chr prefix", { ids <- c("chr1:100:A:G", "chr2:200:C:T") - result <- pecotmr:::variantIdToDf(ids) + result <- parseVariantId(ids) expect_equal(result$chrom, c("1", "2")) }) -test_that("variantIdToDf handles data.frame input with named columns", { +test_that("parseVariantId handles data.frame input with named columns", { df <- data.frame( chrom = c("chr1", "2"), pos = c(100, 200), A2 = c("A", "C"), A1 = c("G", "T") ) - suppressWarnings(result <- pecotmr:::variantIdToDf(df)) + suppressWarnings(result <- parseVariantId(df)) expect_equal(result$chrom, c("1", "2")) expect_equal(result$pos, c(100L, 200L)) }) -test_that("variantIdToDf handles 5-part IDs with build suffix", { +test_that("parseVariantId handles 5-part IDs with build suffix", { ids <- c("chr1:100:A:G:b38", "chr2:200:T:C") - result <- pecotmr:::variantIdToDf(ids) + result <- parseVariantId(ids) expect_equal(ncol(result), 4) expect_equal(colnames(result), c("chrom", "pos", "A2", "A1")) expect_equal(result$chrom, c("1", "2")) @@ -596,9 +532,9 @@ test_that("variantIdToDf handles 5-part IDs with build suffix", { }) -test_that("variantIdToDf handles mixed 4/5-part IDs", { +test_that("parseVariantId handles mixed 4/5-part IDs", { ids <- c("1:100:A:G", "chr2:200:T:C:b38", "3:300:G:A:b37") - suppressWarnings(result <- pecotmr:::variantIdToDf(ids)) + suppressWarnings(result <- parseVariantId(ids)) expect_equal(nrow(result), 3) expect_equal(ncol(result), 4) expect_equal(result$A1, c("G", "C", "A")) @@ -638,79 +574,6 @@ test_that("parseVariantId handles data.frame with generic column names", { expect_equal(result$A1, c("G", "C")) }) -# ============================================================================= - -# ============================================================================= -# regionsOverlap -# ============================================================================= - -test_that("regionsOverlap detects overlapping regions on same chromosome", { - expect_true(regionsOverlap("chr1:100-300", "chr1:200-400")) -}) - - -test_that("regionsOverlap returns FALSE for non-overlapping same-chr regions", { - expect_false(regionsOverlap("chr1:100-200", "chr1:300-400")) -}) - - -test_that("regionsOverlap returns FALSE for different chromosomes", { - expect_false(regionsOverlap("chr1:100-300", "chr2:100-300")) -}) - - -test_that("regionsOverlap detects touching boundaries", { - expect_true(regionsOverlap("chr1:100-200", "chr1:200-300")) -}) - - -test_that("regionsOverlap works with underscore-separated IDs", { - expect_true(regionsOverlap("1_100_300", "1_200_400")) - expect_false(regionsOverlap("1_100_200", "2_100_200")) -}) - - -test_that("regionsOverlap works with data.frame input", { - df_a <- data.frame(chrom = 1, start = 100, end = 300) - df_b <- data.frame(chrom = 1, start = 200, end = 400) - expect_true(regionsOverlap(df_a, df_b)) -}) - -# ============================================================================= -# findOverlappingRegions -# ============================================================================= - -test_that("findOverlappingRegions returns correct indices", { - query <- "chr1:100-300" - targets <- c("chr1:200-400", "chr2:100-200", "chr1:50-150") - result <- findOverlappingRegions(query, targets) - expect_true(1 %in% result) - expect_true(3 %in% result) - expect_false(2 %in% result) -}) - - -test_that("findOverlappingRegions returns empty vector for no matches", { - query <- "chr1:100-200" - targets <- c("chr2:100-200", "chr3:100-200") - result <- findOverlappingRegions(query, targets) - expect_length(result, 0) -}) - - -test_that("findOverlappingRegions works with data.frame targets", { - query <- "chr1:100-300" - targets <- data.frame( - chrom = c(1, 2, 1), - start = c(200, 100, 50), - end = c(400, 200, 150) - ) - result <- findOverlappingRegions(query, targets) - expect_true(1 %in% result) - expect_true(3 %in% result) - expect_false(2 %in% result) -}) - # ============================================================================= # classifyVariantType # ============================================================================= @@ -1250,3 +1113,98 @@ test_that("the rule applies to SNP flip pairs, not just indels", { panel <- c("chr1:200:A:G", "chr1:200:G:A") expect_length(matchVariants("chr1:200:A:G", panel)$idxA, 0L) }) + + +test_that("a convention without an allele separator keeps the default", { + f <- pecotmr:::formatVariantId + expect_equal(f("1", 100L, "A", "G"), "chr1:100:A:G") + # hasChr honoured, alleleSep absent -> ":" retained. + expect_equal( + f("1", 100L, "A", "G", convention = list(hasChr = TRUE)), + "chr1:100:A:G" + ) + # Both honoured. + expect_equal( + f( + "1", + 100L, + "A", + "G", + convention = list(hasChr = FALSE, alleleSep = "_") + ), + "1:100_A_G" + ) +}) + +test_that("columns with no names at all are given placeholder names", { + df <- as.data.frame(matrix(1:4, 2L, 2L)) + colnames(df) <- NULL + out <- pecotmr:::.sanitizeNames(df) + # make.unique de-duplicates the repeated placeholder. + expect_equal(colnames(out), c("unnamed", "unnamed_1")) +}) + +test_that(".harmonizeQcCounts attributes drops with and without INDEL", { + mk <- function(withIndel) { + d <- data.frame( + keep = c(TRUE, FALSE, TRUE), + sign_flip = c(FALSE, FALSE, TRUE), + strand_flip = c(FALSE, TRUE, FALSE), + strand_unambiguous = c(TRUE, FALSE, TRUE), + stringsAsFactors = FALSE + ) + if (withIndel) { + d$INDEL <- c(FALSE, TRUE, FALSE) + } + d + } + bare <- pecotmr:::.harmonizeQcCounts(mk(FALSE)) + expect_equal(bare$considered, 3L) + expect_equal(bare$kept, 2L) + # With no INDEL column nothing can be attributed to indels, so the same + # dropped variant is counted as strand-ambiguous instead. + expect_equal(bare$droppedIndel, 0L) + expect_equal(bare$droppedAmbiguous, 1L) + expect_equal(bare$droppedOther, 0L) + withIndel <- pecotmr:::.harmonizeQcCounts(mk(TRUE)) + expect_equal(withIndel$droppedIndel, 1L) + expect_equal(withIndel$droppedAmbiguous, 0L) + expect_equal(withIndel$droppedOther, 0L) +}) + +test_that(".harmonizeRestoreUnmatched is a no-op when nothing is unmatched", { + matchResult <- data.frame( + A1.ref = c("G", "T"), + A2.ref = c("A", "C"), + variants_id_qced = c("chr1:100:A:G", "chr1:200:C:T"), + keep = c(TRUE, TRUE), + stringsAsFactors = FALSE + ) + result <- data.frame( + variants_id_original = c("chr1:100:A:G", "chr1:200:C:T"), + stringsAsFactors = FALSE + ) + targetData <- data.frame( + chrom = c("chr1", "chr1"), + pos = c(100L, 200L), + A1 = c("G", "T"), + A2 = c("A", "C"), + stringsAsFactors = FALSE + ) + out <- pecotmr:::.harmonizeRestoreUnmatched(result, matchResult, targetData) + # Every target variant is already in the result, so nothing is appended. + expect_identical(out$result, result) + expect_setequal(names(out$qcSummary), c("A1", "A2", "variant_id")) + # Control: an unmatched target variant IS appended. + withExtra <- rbind( + targetData, + data.frame( + chrom = "chr1", pos = 300L, A1 = "A", A2 = "G", + stringsAsFactors = FALSE + ) + ) + appended <- pecotmr:::.harmonizeRestoreUnmatched( + result, matchResult, withExtra + ) + expect_equal(nrow(appended$result), 3L) +}) diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R index 58a9ad4f..403934de 100644 --- a/tests/testthat/test_vcfWriter.R +++ b/tests/testthat/test_vcfWriter.R @@ -1,4 +1,4 @@ -# Tests for writeSumstatsVcf (vcfWriter.R) +# Tests for writeSumStatsVcf (vcfWriter.R) # ============================================================================= # Test data helpers @@ -79,7 +79,7 @@ make_test_finemapping_result <- function(n = 5) { # GwasSumStats to VCF # ============================================================================= -test_that("writeSumstatsVcf writes GwasSumStats to uncompressed VCF", { +test_that("writeSumStatsVcf writes GwasSumStats to uncompressed VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -87,7 +87,7 @@ test_that("writeSumstatsVcf writes GwasSumStats to uncompressed VCF", { out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - result <- writeSumstatsVcf(ss, out) + result <- writeSumStatsVcf(ss, out) expect_equal(result, out) expect_true(file.exists(out)) expect_gt(file.info(out)$size, 0) @@ -97,7 +97,7 @@ test_that("writeSumstatsVcf writes GwasSumStats to uncompressed VCF", { # GwasSumStats to bgzipped VCF # ============================================================================= -test_that("writeSumstatsVcf writes GwasSumStats to bgzipped VCF", { +test_that("writeSumStatsVcf writes GwasSumStats to bgzipped VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -105,7 +105,7 @@ test_that("writeSumstatsVcf writes GwasSumStats to bgzipped VCF", { out <- tempfile(fileext = ".vcf.bgz") on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) - result <- writeSumstatsVcf(ss, out) + result <- writeSumStatsVcf(ss, out) expect_equal(result, out) expect_true(file.exists(out)) expect_gt(file.info(out)$size, 0) @@ -115,7 +115,7 @@ test_that("writeSumstatsVcf writes GwasSumStats to bgzipped VCF", { # FineMappingResult to VCF # ============================================================================= -test_that("writeSumstatsVcf writes FineMappingResult to uncompressed VCF", { +test_that("writeSumStatsVcf writes FineMappingResult to uncompressed VCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -123,20 +123,20 @@ test_that("writeSumstatsVcf writes FineMappingResult to uncompressed VCF", { out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - result <- writeSumstatsVcf(fm, out) + result <- writeSumStatsVcf(fm, out) expect_equal(result, out) expect_true(file.exists(out)) expect_gt(file.info(out)$size, 0) }) -test_that("writeSumstatsVcf(FineMappingResult): emits PIP + CS posterior FORMAT fields", { +test_that("writeSumStatsVcf(FineMappingResult): emits PIP + CS posterior FORMAT fields", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fm <- make_test_finemapping_result(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - writeSumstatsVcf(fm, out) + writeSumStatsVcf(fm, out) ln <- readLines(out) # The posterior fields the legacy create_vcf carried must be present. The CS # field is DYNAMIC (CS) -- the fixture carries cs_95 -> CS95. @@ -155,7 +155,7 @@ test_that("writeSumstatsVcf(FineMappingResult): emits PIP + CS posterior FORMAT # FineMappingResult to BCF # ============================================================================= -test_that("writeSumstatsVcf writes FineMappingResult to BCF", { +test_that("writeSumStatsVcf writes FineMappingResult to BCF", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") skip_if_not_installed("Rsamtools") @@ -204,7 +204,7 @@ test_that("writeSumstatsVcf writes FineMappingResult to BCF", { out <- tempfile(fileext = ".bcf") on.exit(unlink(out), add = TRUE) - result <- writeSumstatsVcf(fm, out) + result <- writeSumStatsVcf(fm, out) expect_equal(result, out) expect_true(file.exists(out)) expect_gt(file.info(out)$size, 0) @@ -214,7 +214,7 @@ test_that("writeSumstatsVcf writes FineMappingResult to BCF", { # Empty FineMappingResult errors # ============================================================================= -test_that("writeSumstatsVcf errors on empty FineMappingResult", { +test_that("writeSumStatsVcf errors on empty FineMappingResult", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") @@ -249,7 +249,7 @@ test_that("writeSumstatsVcf errors on empty FineMappingResult", { out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - expect_error(writeSumstatsVcf(fm_empty, out), "no variants to write") + expect_error(writeSumStatsVcf(fm_empty, out), "no variants to write") }) # ============================================================================= @@ -290,7 +290,7 @@ test_that("writeSumstatsVcf errors on empty FineMappingResult", { ) } -test_that("writeSumstatsVcf(FineMappingResult): splitByContext emits one VCF per context", { +test_that("writeSumStatsVcf(FineMappingResult): splitByContext emits one VCF per context", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() @@ -303,7 +303,7 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext emits one VCF per )), add = TRUE ) - paths <- writeSumstatsVcf(fmr, baseOut, splitByContext = TRUE) + paths <- writeSumStatsVcf(fmr, baseOut, splitByContext = TRUE) expect_length(paths, 2L) # Each path is decorated with the context tag. expect_true(any(grepl("\\.brain\\.vcf$", paths))) @@ -313,7 +313,7 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext emits one VCF per } }) -test_that("writeSumstatsVcf(FineMappingResult): splitByTrait emits one VCF per trait", { +test_that("writeSumStatsVcf(FineMappingResult): splitByTrait emits one VCF per trait", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() @@ -326,13 +326,13 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByTrait emits one VCF per t )), add = TRUE ) - paths <- writeSumstatsVcf(fmr, baseOut, splitByTrait = TRUE) + paths <- writeSumStatsVcf(fmr, baseOut, splitByTrait = TRUE) expect_length(paths, 2L) expect_true(any(grepl("\\.ENSG_A\\.vcf$", paths))) expect_true(any(grepl("\\.ENSG_B\\.vcf$", paths))) }) -test_that("writeSumstatsVcf(FineMappingResult): splitByContext + splitByTrait combines tags", { +test_that("writeSumStatsVcf(FineMappingResult): splitByContext + splitByTrait combines tags", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() @@ -345,7 +345,7 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext + splitByTrait co )), add = TRUE ) - paths <- writeSumstatsVcf( + paths <- writeSumStatsVcf( fmr, baseOut, splitByContext = TRUE, @@ -356,12 +356,12 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext + splitByTrait co expect_true(any(grepl("\\.blood\\.ENSG_B\\.vcf$", paths))) }) -test_that("writeSumstatsVcf(FineMappingResult): multi-row without split flags requires selectors", { +test_that("writeSumStatsVcf(FineMappingResult): multi-row without split flags requires selectors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() out <- tempfile(fileext = ".vcf") - expect_error(writeSumstatsVcf(fmr, out), "2 matching rows") + expect_error(writeSumStatsVcf(fmr, out), "2 matching rows") }) # ============================================================================= @@ -398,25 +398,25 @@ test_that("writeSumstatsVcf(FineMappingResult): multi-row without split flags re ) } -test_that("writeSumstatsVcf(GwasSumStats): multi-study without `study` selector errors", { +test_that("writeSumStatsVcf(GwasSumStats): multi-study without `study` selector errors", { skip_if_not_installed("VariantAnnotation") ss2 <- .make_two_study_gwasSumStats() out <- tempfile(fileext = ".vcf") - expect_error(writeSumstatsVcf(ss2, out), "2 studies") + expect_error(writeSumStatsVcf(ss2, out), "2 studies") }) -test_that("writeSumstatsVcf(GwasSumStats): `study` selector writes the chosen study", { +test_that("writeSumStatsVcf(GwasSumStats): `study` selector writes the chosen study", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss2 <- .make_two_study_gwasSumStats() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - res <- writeSumstatsVcf(ss2, out, study = "studyB") + res <- writeSumStatsVcf(ss2, out, study = "studyB") expect_equal(res, out) expect_true(file.exists(out)) }) -test_that("writeSumstatsVcf(GwasSumStats): emits the AF genotype field when MAF present", { +test_that("writeSumStatsVcf(GwasSumStats): emits the AF genotype field when MAF present", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss <- GwasSumStats( @@ -441,19 +441,19 @@ test_that("writeSumstatsVcf(GwasSumStats): emits the AF genotype field when MAF ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - writeSumstatsVcf(ss, out) + writeSumStatsVcf(ss, out) expect_true(file.exists(out)) # The AF FORMAT field is declared in the header when MAF is present. expect_true(any(grepl("ID=AF", readLines(out)))) }) -test_that("writeSumstatsVcf(GwasSumStats): .vcf.gz output is renamed from writeVcf's .bgz", { +test_that("writeSumStatsVcf(GwasSumStats): .vcf.gz output is renamed from writeVcf's .bgz", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") ss <- make_test_gwasSumStats(5) out <- tempfile(fileext = ".vcf.gz") on.exit(unlink(c(out, paste0(out, ".tbi")), force = TRUE), add = TRUE) - res <- writeSumstatsVcf(ss, out) + res <- writeSumStatsVcf(ss, out) expect_equal(res, out) # writeVcf always emits .bgz; the writer renames it to the requested .gz. expect_true(file.exists(out)) @@ -464,13 +464,13 @@ test_that("writeSumstatsVcf(GwasSumStats): .vcf.gz output is renamed from writeV # FineMappingResult: explicit selectors, no-match error, composite/empty tags # ============================================================================= -test_that("writeSumstatsVcf(FineMappingResult): explicit selectors pick a single row", { +test_that("writeSumStatsVcf(FineMappingResult): explicit selectors pick a single row", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - res <- writeSumstatsVcf( + res <- writeSumStatsVcf( fmr, out, study = "study1", @@ -482,18 +482,18 @@ test_that("writeSumstatsVcf(FineMappingResult): explicit selectors pick a single expect_true(file.exists(out)) }) -test_that("writeSumstatsVcf(FineMappingResult): no matching rows errors", { +test_that("writeSumStatsVcf(FineMappingResult): no matching rows errors", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() out <- tempfile(fileext = ".vcf") expect_error( - writeSumstatsVcf(fmr, out, study = "does_not_exist"), + writeSumStatsVcf(fmr, out, study = "does_not_exist"), "no rows match" ) }) -test_that("writeSumstatsVcf(FineMappingResult): splitByContext decorates composite .vcf.bgz paths", { +test_that("writeSumStatsVcf(FineMappingResult): splitByContext decorates composite .vcf.bgz paths", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fmr <- .make_multi_tuple_qtl_fmr() @@ -510,7 +510,7 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext decorates composi ), add = TRUE ) - paths <- writeSumstatsVcf(fmr, baseOut, splitByContext = TRUE) + paths <- writeSumStatsVcf(fmr, baseOut, splitByContext = TRUE) expect_length(paths, 2L) # Composite extension is preserved while the context tag is injected before it. expect_true(all(grepl("\\.vcf\\.bgz$", paths))) @@ -518,7 +518,7 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext decorates composi expect_true(any(grepl("\\.blood\\.vcf\\.bgz$", paths))) }) -test_that("writeSumstatsVcf(FineMappingResult): splitByContext on a context-less result keeps the path", { +test_that("writeSumStatsVcf(FineMappingResult): splitByContext on a context-less result keeps the path", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # GwasFineMappingResult has no context/trait axes, so the split tag set is @@ -526,13 +526,13 @@ test_that("writeSumstatsVcf(FineMappingResult): splitByContext on a context-less fm <- make_test_finemapping_result(5) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - paths <- writeSumstatsVcf(fm, out, splitByContext = TRUE) + paths <- writeSumStatsVcf(fm, out, splitByContext = TRUE) expect_length(paths, 1L) expect_equal(paths[[1L]], out) expect_true(file.exists(out)) }) -test_that("writeSumstatsVcf(FineMappingResult): emits AF from the topLoci `af` column", { +test_that("writeSumStatsVcf(FineMappingResult): emits AF from the topLoci `af` column", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # The marginal view projects allele frequency to a column named `af`, so a @@ -568,12 +568,12 @@ test_that("writeSumstatsVcf(FineMappingResult): emits AF from the topLoci `af` c ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - writeSumstatsVcf(fm, out) + writeSumStatsVcf(fm, out) expect_true(file.exists(out)) expect_true(any(grepl("ID=AF", readLines(out)))) }) -test_that("writeSumstatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit FORMAT fields", { +test_that("writeSumStatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit FORMAT fields", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") # A rich topLoci exercises every posterior FORMAT field: per-variant logBF (LBF), @@ -615,7 +615,7 @@ test_that("writeSumstatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - writeSumstatsVcf(fm, out) + writeSumStatsVcf(fm, out) ln <- readLines(out) for (id in c( "ID=LBF", @@ -629,7 +629,7 @@ test_that("writeSumstatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit } }) -test_that("writeSumstatsVcf(FineMappingResult): falls back to marginal sumstats when no posterior", { +test_that("writeSumStatsVcf(FineMappingResult): falls back to marginal sumstats when no posterior", { skip_if_not_installed("VariantAnnotation") skip_if_not_installed("Biostrings") fm <- make_test_finemapping_result(5) @@ -641,7 +641,94 @@ test_that("writeSumstatsVcf(FineMappingResult): falls back to marginal sumstats ) out <- tempfile(fileext = ".vcf") on.exit(unlink(out), add = TRUE) - writeSumstatsVcf(fm, out) + writeSumStatsVcf(fm, out) expect_true(file.exists(out)) expect_true(any(grepl("ID=ES", readLines(out), fixed = TRUE))) # marginal beta -> ES }) + + +# =========================================================================== +# Output formats +# =========================================================================== + +test_that("plain and bgzipped VCF are written, the latter with an index", { + skip_if_not_installed("VariantAnnotation") + data(gwasSumStatsS4Example) + d <- withr::local_tempdir() + writeSumStatsVcf(gwasSumStatsS4Example, outputPath = file.path(d, "a.vcf")) + expect_true(file.exists(file.path(d, "a.vcf"))) + writeSumStatsVcf( + gwasSumStatsS4Example, + outputPath = file.path(d, "b.vcf.bgz") + ) + expect_true(file.exists(file.path(d, "b.vcf.bgz"))) + # index = TRUE, so the tabix index is written alongside. + expect_true(file.exists(file.path(d, "b.vcf.bgz.tbi"))) +}) + +test_that("BCF output explains itself when Rsamtools cannot convert", { + # Rsamtools >= 2.26 raises "asBcf() is temporarily disabled". Left bare + # that surfaces as an opaque failure from a documented output format, so + # it is translated into the cause plus the workaround. + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Rsamtools") + data(gwasSumStatsS4Example) + d <- withr::local_tempdir() + canConvert <- !inherits( + tryCatch( + Rsamtools::asBcf("nonexistent", "x", "y"), + error = function(e) e + ), + "error" + ) + skip_if(canConvert, "Rsamtools::asBcf() works here; nothing to translate") + expect_error( + writeSumStatsVcf( + gwasSumStatsS4Example, + outputPath = file.path(d, "c.bcf") + ), + "BCF output needs a working Rsamtools::asBcf" + ) +}) + +test_that(".vcfResolveBody uses posterior rows when no marginals exist", { + local_mocked_bindings( + getTopLoci = function(entry, signalCutoff) { + data.frame(variant_id = c("v1", "v2"), pip = c(0.9, 0.1)) + }, + getMarginalEffects = function(entry) stop("none"), + .package = "pecotmr" + ) + out <- pecotmr:::.vcfResolveBody("e", "S1") + expect_true(out$hasPost) + expect_equal(nrow(out$base), 2L) + # No marginal table to align against, so there is nothing to merge in. + expect_null(out$m) +}) + +test_that(".writeVcfImpl adds the chr prefix to bare chromosome names", { + skip_if_not_installed("VariantAnnotation") + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + geno <- matrix(c(1.5, -0.5), ncol = 1L, dimnames = list(NULL, "S1")) + header <- S4Vectors::DataFrame( + Number = "1", + Type = "Float", + Description = "Z score", + row.names = "Z" + ) + pecotmr:::.writeVcfImpl( + chrom = c("1", "1"), + pos = c(100L, 200L), + ref = c("A", "C"), + alt = c("G", "T"), + snpIds = c("rs1", "rs2"), + geno = list(Z = geno), + genoHeader = header, + sampleName = "S1", + outputPath = out + ) + body <- readLines(out) + body <- body[!startsWith(body, "#")] + expect_true(all(startsWith(body, "chr1\t"))) +}) diff --git a/vignettes/constructing-qtl-datasets.Rmd b/vignettes/constructing-qtl-datasets.Rmd index eb4c6f7a..2b2a5991 100644 --- a/vignettes/constructing-qtl-datasets.Rmd +++ b/vignettes/constructing-qtl-datasets.Rmd @@ -276,6 +276,49 @@ names(getQtlDatasets(msdManual)) To attach a summary-only study, pass a `QtlSumStats` object to the `sumStats` argument. manifest form, supply `sumStatsManifest`, `genome`, and `ldSketch`). +## Excluding related samples + +Both `fineMappingPipeline()` and `twasWeightsPipeline()` fit models that assume +independent samples. Related individuals break that assumption: they inflate +the effective sample size, so cross-validated R-squared comes back optimistic +and PIPs overconfident. Relatedness is therefore a QC step applied *before* the +dataset is built — the pipelines do not model it. + +`filterRelatedness()` takes a kinship table — one row per pair, the shape +PLINK's `--genome` or KING emits — and returns the individuals to **drop**: + +```{r relatedness, eval = requireNamespace("plinkQC", quietly = TRUE) && requireNamespace("igraph", quietly = TRUE)} +relatedness <- data.frame( + IID1 = c(samples[1], samples[3], samples[5]), + IID2 = c(samples[2], samples[4], samples[6]), + PI_HAT = c(0.50, 0.25, 0.125), + stringsAsFactors = FALSE +) +excluded <- filterRelatedness(relatedness, relatednessThreshold = 0.0625) +excluded +unrelated <- setdiff(samples, excluded) +length(unrelated) +``` + +One member of each related pair comes back, chosen so that what remains is as +large an unrelated set as possible. `relatednessThreshold` defaults to 0.0625, +which is third-degree relatives; raise it to 0.125 to keep everyone but +second-degree and closer. + +The exclusion list is not applied for you — feed it to `keepSamples`, the +constructor argument this vignette introduced above, or subset an existing +dataset with `qd[, unrelated, ]`. Both narrow `colData` and `sampleMap` +together. + +`analysisType` changes what is being maximised. The default, +`"maximizeUnrelated"`, keeps the largest unrelated set. `"maximizeCases"` +instead retains as many cases as it can — the right objective for a +case/control design, where cases are the scarce resource — and requires +`phenoData` naming each sample's status. + +`filterRelatedness()` needs the suggested packages **igraph** and **plinkQC**; +the chunk above is skipped when they are not installed. + ## Next steps Once built, the accessors extract data lazily, applying the stored QC filters @@ -291,7 +334,7 @@ dim(SummarizedExperiment::assay(getPhenotypes(qd, contexts = "Muscle"))) ``` `QtlDataset` and `MultiStudyQtlDataset` are direct inputs to -`fineMappingPipeline()`, `twasWeightsPipeline()` and `colocBoostPipeline()`— +`fineMappingPipeline()`, `twasWeightsPipeline()` and `colocboostPipeline()`— see the *Fine-mapping with pecotmr*, *Learning TWAS weights with pecotmr* and *Multi-trait colocalization with ColocBoost* vignettes. diff --git a/vignettes/constructing-sumstats.Rmd b/vignettes/constructing-sumstats.Rmd index 17219bcf..5e25a313 100644 --- a/vignettes/constructing-sumstats.Rmd +++ b/vignettes/constructing-sumstats.Rmd @@ -215,6 +215,42 @@ For a multi-context collection (e.g. as input to `mash`), pass parallel `study` / `context` / `trait` vectors and a matching list of `entry` GRanges — one element per tuple. +## From effect matrices + +Multi-context work often starts from matrices — variants by contexts — +rather than per-context tables. mash in particular produces and consumes that +shape, so two builders take it directly instead of making you assemble +entries by hand. + +`qtlSumStatsFromZMatrix()` takes z-scores, with variant IDs as row names and +contexts as column names: + +```{r from-z} +data(mashInputExample) +z <- mashInputExample$strong.z[1:6, 1:3] +rownames(z) <- paste0("chr1:", seq(1000, by = 100, length.out = 6), ":A:G") +qtlSumStatsFromZMatrix(z, study = "demo") +``` + +`qtlSumStatsFromBetaMatrix()` is the effect-size counterpart, taking `bhat` +and `shat`: + +```{r from-beta} +b <- mashInputExample$strong.b[1:6, 1:3] +shat <- mashInputExample$strong.s[1:6, 1:3] +rownames(b) <- rownames(shat) <- rownames(z) +getContexts(qtlSumStatsFromBetaMatrix(b, shat, study = "demo")) +``` + +Both default `ldSketch = NULL`, giving an LD-free collection. That is fine +for [mash](mash-pipeline.html), which never needs LD, but any RSS method +does — supply a panel if the result is headed for fine-mapping or +TWAS-weight learning. + +The remaining arguments (`genome`, `n`, `a1`, `a2`, `trait`) fill in the +metadata a matrix cannot carry. The allele defaults are placeholders, so set +them if the alleles matter downstream. + ## Reading from files ### Column mapping (YAML) @@ -296,7 +332,7 @@ with bgzip and indexed with tabix. **BCF is not supported** — convert to a bgzipped VCF first. Support for reading VCFs requires the `VariantAnnotation` package. -```{r gwas-vcf, eval=hasVA} +```{r gwas-vcf, eval = requireNamespace("VariantAnnotation", quietly = TRUE)} vcfLines <- c( "##fileformat=VCFv4.2", '##FORMAT=', @@ -363,7 +399,7 @@ gws_qcd <- summaryStatsQc(gws, zMismatchQc = "slalom") See the *Quality Control for GWAS and QTL Summary Statistics* vignette for the full QC pipeline. `QtlSumStats` and `GwasSumStats` are direct inputs to `fineMappingPipeline()`, `twasWeightsPipeline()` (`QtlSumStats` only) and -`colocBoostPipeline()`— see the *Fine-mapping with pecotmr*, *Learning TWAS +`colocboostPipeline()`— see the *Fine-mapping with pecotmr*, *Learning TWAS weights with pecotmr* and *Multi-trait colocalization with ColocBoost* vignettes. diff --git a/vignettes/ctwas-pipeline.Rmd b/vignettes/ctwas-pipeline.Rmd new file mode 100644 index 00000000..6e0310a8 --- /dev/null +++ b/vignettes/ctwas-pipeline.Rmd @@ -0,0 +1,328 @@ +--- +title: "Causal TWAS with ctwasPipeline" +author: "pecotmr authors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Causal TWAS with ctwasPipeline} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +hasCtwas <- requireNamespace("ctwas", quietly = TRUE) +knitr::opts_chunk$set( + echo = TRUE, + message = FALSE, + warning = FALSE, + fig.width = 7, + fig.height = 4.5, + eval = hasCtwas +) +# cTWAS narrates each step through the logging package, which writes to +# stdout rather than as messages, so knitr cannot filter it. Quieten it here +# to keep the output readable -- in your own session the log is worth +# watching, since it reports region counts and EM convergence. +if (hasCtwas) { + logging::setLevel("WARN") +} +``` + +```{r ctwas-missing, echo=FALSE, eval=!hasCtwas, results="asis"} +cat( + "**Note:** the `ctwas` package is not installed, so the code below is", + "shown but not run. Install it from", + "." +) +``` + +## Overview + +A TWAS Z-score (see the +[TWAS Z-score + MR vignette](twas-zscore.html)) asks whether a gene's +predicted expression associates with the trait. It asks that question one +gene at a time, so a gene can score highly purely because it sits near a +strong GWAS signal that is really driven by a nearby variant. + +`ctwasPipeline()` runs +[cTWAS](https://github.com/xinhe-lab/multigroup_ctwas), which fine-maps +**genes and SNPs jointly within each LD block**. A gene's posterior +inclusion probability is therefore conditioned on the SNP signal beside it, +which is what separates a gene that carries the association from one that +merely neighbours it. + +Inputs: + +| Argument | What it is | +|---|---| +| `gwasSumStats` | one `GwasSumStats` whose elements are LD blocks | +| `twasWeights` | per-gene `TwasWeights` / `QtlFineMappingResult` | +| `twasZ` | optional pre-computed per-gene Z from `causalInferencePipeline()` | +| `fineMappingResult` | optional; enables the credible-set and PIP variant rescues | + +```{r load-packages} +library(pecotmr) +``` + +## The LD block convention + +`gwasSumStats` is **one** `GwasSumStats` object whose elements are LD +blocks, keyed by its `blockId` column — not a list of per-block objects. +Build it with `loadGwasSumStatsFromManifest(..., ldBlocks = )` and +pass it through `summaryStatsQc()`. + +A single-block input is rejected: cTWAS estimates its group priors by EM +across regions, and one region gives it nothing to average over. + +```{r bundled} +ldStem <- file.path( + system.file("extdata", "ld_reference", "chr22", package = "pecotmr"), + "protocol_example.LD.chr22" +) +gwasTsv <- system.file( + "extdata", + "manifests", + "protocol_example.twas.gwas_sumstats.chr22.tsv.gz", + package = "pecotmr" +) + +blocks <- GenomicRanges::GRanges( + "chr22", + IRanges::IRanges(c(10000000, 15000001), c(15000000, 19000000)), + blockId = c("chr22_1", "chr22_2") +) + +gwasSumStats <- loadGwasSumStatsFromManifest( + manifest = data.frame(study = "gwas1", sumStatsPath = gwasTsv), + genome = "hg38", + ldSketch = ldStem, + region = "chr22:10000000-19000000", + ldBlocks = blocks +) +gwasByRegion <- summaryStatsQc(gwasSumStats, mafCutoff = 0.0025) + +data(ctwasWeightsExample) +``` + +## Running the pipeline + +```{r ctwas-run} +res <- ctwasPipeline( + gwasSumStats = gwasByRegion, + twasWeights = list(ctwasWeightsExample), + thin = 1, + niterPrefit = 3, + niter = 10, + min_group_size = 1, + min_p_single_effect = 0, + min_nonSNP_PIP = 0, + fallbackToPrefit = TRUE +) +res +``` + +The settings above are sized for a toy dataset and are **not** defaults you +should carry into a real analysis: + +- `thin = 1` keeps every SNP (production runs thin to `0.1`). +- `niterPrefit` / `niter` are cut to keep the vignette fast. +- `min_nonSNP_PIP = 0` disables region screening. The bundled GWAS has no + genome-wide-significant signal, so the default (`0.5`) selects no region at + all and the result comes back empty. On real data, leave it alone. +- `fallbackToPrefit = TRUE` recovers from the accurate-EM step returning + `NaN` on underpowered data by keeping the prefit estimates. + +## Where genes come from + +`twasWeights` accepts two shapes: + +- a **flat** `TwasWeights` or `QtlFineMappingResult` (or a homogeneous list + of them) carrying `region` provenance. Each gene is assigned to its home + LD block by `start(region)`, matching cTWAS's own placement rule. +- a **pre-bucketed named list** keyed by `region_id`, used as-is. + +Blocks with no gene weights still contribute their SNP-level signal to the +group prior — the whole-chromosome pattern where only a few blocks carry +genes. + +A gene whose cis window straddles a block boundary is assigned by its single +anchor. The signal it loses across the boundary is a separate concern, +handled by `mergeCtwasBoundaryRegions()` below. + +## Trimming each gene's variants + +Weight matrices from a permissive QTL model can be large, and cTWAS's cost +scales with them. Four arguments trim each gene before cTWAS sees it: + +| Argument | Effect | +|---|---| +| `twasWeightCutoff` | drop variants with `abs(weight)` below the cutoff | +| `maxNumVariants` | cap variants per gene | +| `csMinCor` | keep variants in a credible set with purity at least this | +| `minPipCutoff` | keep variants with PIP above this | + +`csMinCor` and `minPipCutoff` mark variants as must-keep, so they survive +the `maxNumVariants` cap. Both need a `fineMappingResult`; without one they +are no-ops and the cap falls back to ordering by `abs(weight)`. + +```{r ctwas-filters, eval=FALSE} +ctwasPipeline( + gwasSumStats = gwasByRegion, + twasWeights = list(ctwasWeightsExample), + fineMappingResult = fmr, + twasWeightCutoff = 1e-4, + maxNumVariants = 1000, + csMinCor = 0.8, + minPipCutoff = 0.1 +) +``` + +## Reading the result + +`ctwasPipeline()` returns a `CtwasResult`: one row per +`(gwasStudy, study, context, method)` run. + +```{r ctwas-identity} +getMethodNames(res) +getStudy(res) +getContexts(res) +``` + +The per-gene posteriors live in `getFinemap()`: + +```{r ctwas-finemap} +fm <- getFinemap(res) +as.data.frame(fm)[, c( + "molecular_id", + "context", + "region_id", + "z", + "susie_pip", + "cs" +)] +``` + +`susie_pip` is the quantity cTWAS exists to produce: the probability the +gene is causal given the SNPs it competes with. Here it is low (the toy GWAS +has no real signal) and `cs` is `NA` because the gene falls in no credible +set. + +`getSusieAlpha()` returns the per-single-effect alpha matrix behind those +PIPs, and the EM group priors sit on each row's entry: + +```{r ctwas-param} +param <- getCtwasParam(res$entry[[1]]) +param$group_prior +param$group_prior_var +param$converged +``` + +By default the context-agnostic SNP background is dropped from the result, +since it is the null the genes are being scored against rather than a +finding. Pass `keepSnps = TRUE` to retain it as an extra row +(`study = context = "SNP"`), which makes the full cTWAS output +reconstructable. + +## The four chainable steps + +`ctwasPipeline()` is a wrapper over four steps. Call them directly when you +want to inspect an intermediate payload, override the estimated priors, or +re-enter the chain without recomputing what came before. + +```{r ctwas-granular} +inputs <- assembleCtwasInputs( + gwasSumStats = gwasByRegion, + twasWeights = list(ctwasWeightsExample) +) +est <- estCtwasParam( + inputs, + thin = 1, + niterPrefit = 3, + niter = 10, + min_group_size = 1, + min_p_single_effect = 0, + fallbackToPrefit = TRUE +) +screened <- screenCtwasRegions(est, min_nonSNP_PIP = 0) +finemapped <- finemapCtwasRegions(screened) +nrow(finemapped$finemap_res) +``` + +`finemap_res` here has more rows than `getFinemap(res)` above: it still +carries the SNP rows. `asCtwasResult()` is the step that structures the +payload and drops them. + +```{r ctwas-as-result} +nrow(getFinemap(asCtwasResult(finemapped))) +nrow(getFinemap(asCtwasResult(finemapped, keepSnps = TRUE))) +``` + +Each step's payload is also bundled, so you can enter anywhere: + +```{r ctwas-bundled-payloads, eval=FALSE} +data(ctwasInputsExample) # after assembleCtwasInputs +data(ctwasEstExample) # after estCtwasParam +data(ctwasFinemapExample) # after finemapCtwasRegions +``` + +The most common reason to use the granular path is to override the priors. +`estCtwasParam()`'s accurate-EM step can diverge on underpowered data; +`fallbackToPrefit = TRUE` handles that automatically, but taking the steps +apart lets you substitute priors of your own into `screenCtwasRegions()`. + +## Boundary genes + +A gene whose cis window crosses an LD block boundary is fine-mapped in only +one of the two blocks. `mergeCtwasBoundaryRegions()` re-runs such genes over +the merged pair: + +```{r ctwas-merge, eval=FALSE} +merged <- mergeCtwasBoundaryRegions( + finemapped, + pipThresh = 0.5, + filterCs = FALSE, + maxSNP = Inf +) +``` + +`ctwasPipeline(mergeBoundary = TRUE)` does the same thing inline, with +`mergePipThresh` / `mergeFilterCs` / `mergeMaxSNP` forwarding to those +arguments. It is off by default because it only matters when a +high-PIP gene actually straddles a boundary. + +## Common parameters + +```{r ctwas-params, eval=FALSE} +ctwasPipeline( + gwasSumStats = gwasByRegion, + twasWeights = list(ctwasWeightsExample), + method = NULL, # NULL: "ensemble" if present, else every method + thin = 0.1, + niterPrefit = 3, + niter = 30, + L = 5, + groupPriorVarStructure = "shared_type", + ncore = 1, + keepSnps = FALSE, + mergeBoundary = FALSE, + fallbackToPrefit = FALSE +) +``` + +When `method` is `NULL` and several weight methods are present without an +`"ensemble"`, each method runs as its own independent cTWAS run and +contributes its own row-set. + +## Next steps + +- [TWAS weights](twas-weights.html) — training the weights cTWAS consumes. +- [TWAS Z-scores and MR](twas-zscore.html) — the per-gene Z that + `twasZ` optionally supplies here. +- [QC for summary statistics](rss-qc.html) — `summaryStatsQc()`, which + `gwasSumStats` must have been through. + +# Session info + +```{r session-info} +sessionInfo() +``` diff --git a/vignettes/fine-mapping.Rmd b/vignettes/fine-mapping.Rmd index 10ceb648..9189abbb 100644 --- a/vignettes/fine-mapping.Rmd +++ b/vignettes/fine-mapping.Rmd @@ -26,10 +26,10 @@ following inputs: | Input class | What it represents | Methods supported | |---|---|---| -| `QtlDataset` | Single-study individual-level data | susie, susieInf, susieAsh, mvsusie, fsusie, susieSer | -| `MultiStudyQtlDataset` | Multiple `QtlDataset` objects (optionally with an embedded `QtlSumStats`) | susie, susieInf, susieAsh, mvsusie, fsusie (individual-level only), susieSer (individual-level only)| -| `QtlSumStats` | QTL summary statistics annotated by `(study, context, trait)` | susie, susieInf, susieAsh, mvsusie | -| `GwasSumStats` | GWAS summary statistics annotated by `study` | susie, susieInf, susieAsh, mvsusie | +| `QtlDataset` | Single-study individual-level data | susie, susieInf, susieAsh, mvsusie, fsusie | +| `MultiStudyQtlDataset` | Multiple `QtlDataset` objects (optionally with an embedded `QtlSumStats`) | susie, susieInf, susieAsh, mvsusie, fsusie (individual-level only), ser (via an embedded `QtlSumStats`) | +| `QtlSumStats` | QTL summary statistics annotated by `(study, context, trait)` | susie, susieInf, susieAsh, mvsusie, ser | +| `GwasSumStats` | GWAS summary statistics annotated by `study` | susie, susieInf, susieAsh, ser | Method arguments are the same across input classes; `fineMappingPipeline()` routes `methods = "susie"` to `susieR::susie` for individual-level data @@ -246,6 +246,35 @@ window <- GenomicRanges::GRanges( sum(lengths(subsetRegion(fmr, window))) ``` +## Calling a fitter directly + +Each `methods =` value dispatches to an exported fitting function, usable on +its own when you have matrices rather than a `QtlDataset`: + +| `methods =` | Individual-level | Summary-statistics | +|---|---|---| +| `susie` | `susieWeights()` | `susieRssWeights()` | +| `susieInf` | `susieInfWeights()` | `susieInfRssWeights()` | +| `susieAsh` | `susieAshWeights()` | `susieAshRssWeights()` | +| `mvsusie` | `mvsusieWeights()` / `fitMvsusie()` | `mvsusieRssWeights()` / `fitMvsusieRss()` | +| `fsusie` | `fsusieWeights()` / `fitFsusie()` | — | + +The `*Weights()` functions return a weight vector, which is what makes a +fine-mapper usable as a [TWAS weight method](twas-weights.html); the +`fit*()` functions return the fit object itself when you want the posterior +rather than the coefficients. + +Two are worth calling out: + +- `fsusieWrapper()` wraps `fitFsusie()` with the credible-band and + affected-region post-processing, and `fsusieGetCs()`, + `fsusieCredibleBand()` and `fsusieAffectedRegions()` read those out. + fSuSiE needs a *functional* phenotype — a curve per sample, not a scalar — + so it does not accept the same `Y` the other methods do. +- `fitSusieInfThenSusieRss()` chains the two: `susie_inf` first to estimate + the infinitesimal component, then SuSiE-RSS on the residual signal. That + is what `methods = "susieInf"` runs on summary statistics. + ## Next steps - `QtlFineMappingResult` is used by [`colocPipeline`](coloc-pipeline.html) for diff --git a/vignettes/finemapping-postprocessing.Rmd b/vignettes/finemapping-postprocessing.Rmd new file mode 100644 index 00000000..f568effc --- /dev/null +++ b/vignettes/finemapping-postprocessing.Rmd @@ -0,0 +1,295 @@ +--- +title: "Post-processing fine-mapping results" +author: "pecotmr authors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Post-processing fine-mapping results} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + echo = TRUE, + message = FALSE, + warning = FALSE, + fig.width = 7, + fig.height = 4.5 +) +``` + +## Overview + +[`fineMappingPipeline()`](fine-mapping.html) returns a +`QtlFineMappingResult` or `GwasFineMappingResult`. This vignette covers what +you do with one afterwards: summarising credible sets, comparing results +across studies, intersecting QTL with GWAS, and reaching the underlying +SuSiE quantities when the summaries are not enough. + +Every function here reads an existing result — none of them refit anything. + +```{r load-packages} +library(pecotmr) +data(qtlFineMappingExample, gwasFineMappingExample) +data(qtlFineMappingLbfExample, gwasFineMappingLbfExample) +data(qtlFineMappingPairedExample, qtlDatasetExample) +qtlFineMappingExample +``` + +## The two tables + +A fine-mapping result carries two flat summaries, and which one you want +depends on whether your unit of interest is a variant or a credible set. + +**`getTopLoci()`** is one row per retained variant, with its PIP, effect +size, and credible-set membership at each coverage level: + +```{r top-loci} +topLoci <- getTopLoci(qtlFineMappingExample) +dim(topLoci) +head(as.data.frame(topLoci)[, c( + "variant_id", + "pip", + "cs_95", + "cs_95_purity", + "beta", + "se" +)], 4) +``` + +`cs_95` names the credible set the variant belongs to, or is `NA` when it +belongs to none. The `cs_70` / `cs_50` columns give the same membership at +looser coverage, so a variant can be in a 95% set but not a 50% one. + +**`getCredibleSetSummary()`** is one row per credible set instead: + +```{r cs-summary} +as.data.frame(getCredibleSetSummary(qtlFineMappingExample))[, c( + "cs", + "coverage", + "n_variants", + "purity_min", + "cs_log10bf", + "lead_variant", + "lead_pip" +)] +``` + +`purity_min` is the smallest absolute correlation between any pair of +variants in the set — the standard measure of whether a credible set is a +single signal or an artefact of a few uncorrelated variants being lumped +together. `cs_log10bf` says how much the data prefer that effect being +present. + +A credible set with low `purity_min` deserves suspicion before +interpretation, which is why the pipeline exposes `minPurity` as a filter +rather than dropping such sets silently. + +## Merging overlapping credible sets + +A multi-effect SuSiE fit can return credible sets that overlap, especially +when two effects are in strong LD. `mergeSusieCs()` collapses those into one +row per variant: `credibleSetNames` labels every set the variant belongs to +(comma-joined when it belongs to more than one), and `maxPip` / `medianPip` +summarise its PIP across them. The example fit has a single set, so each +label names just that one: + +```{r merge-cs} +merged <- mergeSusieCs(qtlFineMappingExample, coverage = 0.95) +dim(merged) +head(as.data.frame(merged), 4) +``` + +Use it when downstream code needs a variant to belong to at most one set — +overlap-counting, for instance, would otherwise double-count. + +## Intersecting QTL and GWAS + +`overlapTopLoci()` joins two fine-mapping results on shared variants, +prefixing each side's columns. It is the cheap first pass before +[colocalization](coloc-pipeline.html): if the two credible sets share no +variants at all, there is nothing for a coloc model to work with. + +```{r overlap} +overlap <- overlapTopLoci(qtlFineMappingLbfExample, gwasFineMappingLbfExample) +nrow(overlap) +head(as.data.frame(overlap)[, c( + "variant_id", + "qtl_pip", + "gwas_pip", + "qtl_cs_95", + "gwas_cs_95" +)], 4) +``` + +The variants worth attention are those in a credible set on *both* sides: + +```{r overlap-both} +both <- overlap[!is.na(overlap$qtl_cs_95) & !is.na(overlap$gwas_cs_95), ] +nrow(both) +table(both$qtl_cs_95, both$gwas_cs_95) +``` + +Here that filter removes nothing, because `topLoci` in this result retains +only credible-set variants — every shared variant is in one set on each +side. The filter earns its place on results where `topLoci` also carries +high-PIP variants outside any set, which is the usual case once +`pipCutoff` is in play. + +A non-empty overlap is not evidence of a shared causal variant, however +large: two independent signals in the same LD block overlap too. That +question is what `colocPipeline()` answers. + +## Combining results + +`combineFineMappingResults()` stacks several results into one collection, +which is how per-region or per-chromosome runs are assembled after +parallel execution: + +```{r combine} +combined <- combineFineMappingResults( + qtlFineMappingExample, + qtlFineMappingLbfExample +) +nrow(combined) +data.frame( + study = combined$study, + context = combined$context, + trait = combined$trait, + method = combined$method +) +``` + +The inputs keep their own identity columns, so a combined object still +distinguishes which study and method each row came from. Note that the +identity columns are read with `$`: `as.data.frame()` on a collection +flattens its *variants*, not its per-row metadata. + +## Between-credible-set correlation + +`computeCsCorrelation()` reports how correlated a fit's credible sets are +with each other. It is computed on demand rather than stored, because it +needs LD — and the LD lives with the data, not with the fit: + +```{r cs-corr} +computeCsCorrelation(qtlFineMappingPairedExample, qtlDatasetExample) +``` + +The `ldSource` argument takes a `QtlDataset`, `QtlSumStats` or +`GwasSumStats` — whichever object the fit was derived from. It must cover +the fit's region: a source whose variants do not reach the fit's window +cannot supply the correlations, and the function says so rather than +returning something empty. + +Near-zero off-diagonal entries, as here, mean the credible sets are +capturing distinct signals. Strongly correlated sets suggest the fit split +one signal in two. + +## Reaching the SuSiE quantities + +When the flat tables are not enough — you want the per-effect posterior, or +to re-derive PIPs under a different assumption — the underlying fit is +available. + +`getLbf()` returns the log Bayes factors, one row per variant and one +column per single effect: + +```{r lbf} +lbf <- getLbf(qtlFineMappingLbfExample) +unit <- lbf[lbf$trait == lbf$trait[1] & lbf$context == lbf$context[1], ] +lbfMatrix <- as.matrix(unit[, grep("^lbf_L", names(unit))]) +dim(lbfMatrix) +``` + +`lbfToAlpha()` converts those to single-effect inclusion probabilities. +It normalises **across each row**, so the matrix has to be oriented with +effects as rows — transpose the variants-by-effects layout above: + +```{r lbf-alpha} +alpha <- lbfToAlpha(t(lbfMatrix)) +dim(alpha) +rowSums(alpha) # each single effect sums to 1 across variants +``` + +Getting that orientation wrong is quiet rather than loud: normalising across +effects for each variant also produces a matrix whose rows sum to 1, just +not one that means anything. + +The LBF matrix is also what `colocPipeline()` consumes, which is why +`fineMappingPipeline(..., keepLbf = TRUE)` is required before +colocalization. + +`getSusieFit()` returns the raw per-unit SuSiE object when you need +something the accessors do not expose: + +```{r susie-fit} +fit <- getSusieFit(qtlFineMappingExample) +class(fit) +names(fit) +``` + +`alpha` and `lbf_variable` are the per-effect matrices, `sets` the credible +sets before any purity filtering, and `V` the estimated prior variances — +everything the flat tables above are derived from. + +## How the tables are built + +The summaries above are not stored by the fitter — they are derived from the +raw SuSiE fit by a short chain that `fineMappingPipeline()` runs for you: + +``` +postprocessFinemappingFits() # per-method fits -> a post object + -> computeCsTables() # credible sets from alpha, with purity + -> buildTopLoci() # the flat one-row-per-variant table + -> formatFinemappingOutput() # assemble the result payload +``` + +Call them directly when you have SuSiE fits from elsewhere and want +pecotmr's tables over them, or when you need to change how credible sets are +formed — `computeCsTables()` is where the coverage levels and purity +threshold are applied, so re-running it with a different `coverage` gives a +different `top_loci` without refitting anything. + +Two smaller extractors sit at the row level and are what +`getCredibleSetSummary()` is assembled from: + +- `extractCsInfo(fmRow, csNames, topLociTable, ldSource)` — per-credible-set + detail for one result row, including the between-variant correlations that + give `purity_min`, which is why it needs an `ldSource`. +- `extractTopPipInfo(fmRow, sumstats)` — the lead variant and its statistics, + joined against summary statistics. + +`getSusieResult()` unwraps a per-condition fit list into the single SuSiE +object the other helpers expect. + +## Writing results out + +`writeSumStatsVcf()` serialises a fine-mapping result — or summary +statistics — to GWAS-VCF, the interchange format most external tools read: + +```{r vcf, eval=FALSE} +writeSumStatsVcf( + qtlFineMappingExample, + file = "finemapping.vcf.gz", + genome = "hg38" +) +``` + +It needs the `VariantAnnotation` package, which is a suggested dependency +rather than a hard one. + +## Next steps + +- [Fine-mapping](fine-mapping.html) — producing the results this vignette + consumes. +- [Colocalization](coloc-pipeline.html) — the model that answers whether an + overlap reflects a shared causal variant. +- [TWAS weights](twas-weights.html) — reusing a fine-mapping fit as a weight + method. + +# Session info + +```{r session-info} +sessionInfo() +``` diff --git a/vignettes/heritability.Rmd b/vignettes/heritability.Rmd new file mode 100644 index 00000000..dddc5042 --- /dev/null +++ b/vignettes/heritability.Rmd @@ -0,0 +1,385 @@ +--- +title: "SNP heritability and functional enrichment" +author: "pecotmr authors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{SNP heritability and functional enrichment} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + echo = TRUE, + message = FALSE, + warning = FALSE, + fig.width = 7, + fig.height = 4.5 +) +``` + +## Overview + +`estimateH2()` estimates SNP heritability from GWAS summary statistics and +an LD reference. Four estimators are available, differing in what they model +and what they need: + +| `method` | Approach | LD input | +|---|---|---| +| `"sldsc"` | Stratified LD score regression (Finucane 2015) | `LdScore` | +| `"gldsc"` | Generalized LDSC — GLS with full block LD (Xiong 2024) | `LdScore` + matrices | +| `"lder"` | LD eigenvalue regression (Song 2022) | `LdEigen` | +| `"hdl"` | High-definition likelihood (Ning 2020) | `LdEigen` | + +Supplying `annotations` makes any of them stratified, adding a +per-annotation enrichment table. + +There is a second, separate track in the package: when stratified LDSC has +already been run externally by [polyfun][pf], `sldscPostprocessingPipeline()` +postprocesses those outputs. Both are covered below. + +[pf]: https://github.com/omerwe/polyfun + +```{r load-packages} +library(pecotmr) +data(ldScoreExample, ldEigenExample) +ldScoreExample +``` + +Both bundled references describe the same 1300 variants across 14 chr22 LD +blocks, taken from the de-identified `protocol_example` panel, so the four +methods can be compared on one dataset. + +## Variants must line up + +Every estimator reads the z-scores positionally, indexed by the LD +reference's own variant order — nothing is matched on variant ID along the +way. `estimateH2()` therefore checks up front that the summary statistics, +the annotations and the reference describe the same variants, in the same +order, on the same genome build, and refuses to run otherwise. + +The practical consequence: build the summary statistics *from* the reference +rather than alongside it. + +```{r simulate-gwas} +# A GWAS simulated on this reference so the true h2 is known: z is drawn +# from the standard model z ~ N(0, N R diag(v) R + R), block by block. +M <- length(ldScoreExample) +nGwas <- 10000 +h2True <- 0.4 +perSnpVar <- rep(h2True / M, M) + +set.seed(1) +z <- numeric(M) +for (block in getLdMatrixList(ldScoreExample)) { + idx <- block$snpIdx + p <- length(idx) + sigma <- nGwas * (block$R %*% diag(perSnpVar[idx], p) %*% block$R) + + block$R + e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) + z[idx] <- as.vector(e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p))) +} + +gr <- as(ldScoreExample, "GRanges") +S4Vectors::mcols(gr) <- S4Vectors::DataFrame( + SNP = names(ldScoreExample), + A1 = S4Vectors::mcols(ldScoreExample)$A1, + A2 = S4Vectors::mcols(ldScoreExample)$A2, + Z = z, + N = as.integer(nGwas) +) +gwas <- GwasSumStats( + study = "trait1", + entry = list(gr), + genome = getGenome(ldScoreExample), + ldSketch = readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) +) +``` + +## Estimating heritability + +```{r estimate} +methods <- c("sldsc", "gldsc", "lder", "hdl") +estimates <- lapply(methods, function(m) { + ref <- if (m %in% c("sldsc", "gldsc")) ldScoreExample else ldEigenExample + suppressWarnings(estimateH2(gwas, ref, method = m)) +}) +names(estimates) <- methods + +data.frame( + method = methods, + h2 = round(vapply(estimates, getH2, numeric(1)), 3), + se = round(vapply(estimates, getH2Se, numeric(1)), 3), + row.names = NULL +) +``` + +The true value is `r h2True`. Three of the four land close to it; `sldsc` +comes in low, and that is worth understanding rather than tuning away. + +**`sldsc` is attenuated because the reference is small.** LD score +regression is a genome-scale method — real analyses regress over roughly a +million variants. On 1300 the intercept is not identifiable: an unweighted +OLS on this same data returns an intercept several times its true value of +1, and the heritability absorbs the difference. `lder` is the least +sensitive to reference size, which is why it is the default. + +All four are checked against their reference implementations — [ldsc][ldsc], +[HDL][hdl], [LDER][lder] and [gldsc][gldsc] — on identical inputs: HDL agrees +exactly, LDER to machine precision, gLDSC to ~3e-8 and S-LDSC to ~1e-6. The +small residuals are a ridge on the weighted solve, which keeps an exactly +singular design from returning `NA`. Agreement holds even where the +reference implementations misbehave, such as an S-LDSC intercept below 1 or +a negative partitioned heritability. + +One deliberate difference: LDER here clamps negative eigenvalues before +forming its regression weights. A real, rank-deficient LD block decomposes +with a tail of tiny negative values that are floating-point noise, and +upstream takes `sqrt()` of the resulting negative weight and aborts. The +clamp changes nothing wherever upstream runs. + +[ldsc]: https://github.com/bulik/ldsc +[hdl]: https://github.com/zhenin/HDL +[lder]: https://github.com/shuangsong0110/LDER +[gldsc]: https://github.com/xzw20046/gldsc + +**`hdl` has a reference-size limit, and it tells you when it hits it.** It +is the only one of the four that models reference-panel *noise* explicitly: +its likelihood subtracts a term scaling as `1/nRef` from the modelled +variance. Once the reference is small relative to the GWAS, that term +outgrows the signal, the modelled variance is driven to its floor across +most eigen-directions, and the optimiser walks the intercept out to the top +of its range — returning a number that reflects that bound rather than the +data. At `N = 1e5` against this reference (`nRef` = +`r getNRef(ldEigenExample)`) it drifts to about 0.56 for a true 0.4 and +warns that the fit sits on a bound. At the `N = 1e4` used here it is +comfortably inside its range. If HDL disagrees sharply with the others, +check for that warning and compare `getN()` against `getNRef()`. + +A standard error of zero, or an estimate pinned at a boundary, almost always +means the reference is too small rather than that the trait has no +heritability. The block jackknife needs at least two LD blocks and wants many +more; `estimateH2()` refuses a single-block reference outright. + +## Building an LD reference + +The bundled references were built with `buildLdEigen()` / `buildLdScore()`, +which turn already-loaded LD into the statistic each estimator needs. Load +the LD **per block** — loading a whole region at once returns one dense +matrix, which is one block, and one block has no jackknife. + +```{r build-ref, eval=FALSE} +metaPath <- "/path/to/ld_meta_file.tsv" +blocks <- read.delim(metaPath, check.names = FALSE) +regions <- sprintf("chr22:%d-%d", blocks$start, blocks$end) + +ldList <- lapply(regions, function(r) loadLdMatrix(metaPath, region = r)) + +ldEigen <- buildLdEigen(ldList, genome = "hg38") +ldScore <- buildLdScore(ldList, genome = "hg38") +``` + +`nRef` and the genome build default to what the loaded LD records. +`buildLdScore(keepLdMatrices = FALSE)` drops the per-block matrices, which +shrinks the object by roughly an order of magnitude — but only unstratified +`"sldsc"` can use the result, since `"gldsc"` and stratified `"sldsc"` both +form their per-annotation scores from those matrices. + +## Stratified estimation and enrichment + +Passing an `AnnotationMatrix` partitions heritability across annotations. +The annotation rows must line up with the reference, exactly as the summary +statistics do. + +```{r annotate} +# An illustrative annotation over the first half of the reference, simulated +# to carry three times the per-variant heritability of the rest. +inA <- seq_len(M) <= M / 2 +perSnpVarStrat <- ifelse(inA, 0.225 / sum(inA), 0.075 / sum(!inA)) + +set.seed(1) +zStrat <- numeric(M) +for (block in getLdMatrixList(ldScoreExample)) { + idx <- block$snpIdx + p <- length(idx) + sigma <- nGwas * + (block$R %*% diag(perSnpVarStrat[idx], p) %*% block$R) + + block$R + e <- eigen((sigma + t(sigma)) / 2, symmetric = TRUE) + zStrat[idx] <- as.vector( + e$vectors %*% (sqrt(pmax(e$values, 0)) * rnorm(p)) + ) +} +S4Vectors::mcols(gr)$Z <- zStrat +gwasStrat <- GwasSumStats( + study = "trait1", + entry = list(gr), + genome = getGenome(ldScoreExample), + ldSketch = readGenotypes( + system.file("extdata", "toy_ref.bed", package = "pecotmr") + ) +) + +annot <- AnnotationMatrix( + matrix(as.integer(inA), ncol = 1, dimnames = list(NULL, "annotA")), + as(ldScoreExample, "GRanges"), + data.frame(name = "annotA", tier = "baseline", type = "binary"), + genome = getGenome(ldScoreExample) +) +``` + +```{r enrichment} +strat <- estimateH2( + gwasStrat, + ldScoreExample, + method = "gldsc", + annotations = annot +) +as.data.frame(getEnrichment(strat))[, c( + "annotation", + "tau", + "enrichment", + "enrichmentSe", + "propH2", + "propSnps" +)] +``` + +`enrichment` is the proportion of heritability divided by the proportion of +variants: above 1 means the annotation carries more heritability than its +share of the genome. The simulated truth here is 3, and the estimate is +directionally right but attenuated — again a consequence of the reference's +size rather than of the annotation. + +Annotations come from files via `readAnnotations()`, which reads BED, BigWig +and LDSC `.annot` formats at a given set of variant positions: + +```{r read-annotations, eval=FALSE} +annot <- readAnnotations( + c(enhancer = "enhancers.bed", conservation = "phastCons.bw"), + snpRanges = as(ldScoreExample, "GRanges"), + genome = "hg38" +) +``` + +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 `getScoreStats()`). + +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. + +## Postprocessing external polyfun runs + +The second track handles stratified LDSC that was run outside R by polyfun. +The readers load its outputs, `SldscData` bundles them, and the pipeline +does the computation — no file I/O of its own. + +```{r sldsc-read} +sldscDir <- system.file("extdata", "sldsc", package = "pecotmr") +traitDir <- system.file("extdata", "sldsc_trait", package = "pecotmr") + +annotTable <- readSldscAnnot(sldscDir) +frq <- readSldscFrq(sldscDir, plinkName = "reference.") + +traitNames <- c(traitA = "sumstats", traitB = "sumstats2", traitC = "sumstats3") +runs <- lapply(traitNames, function(t) { + readSldscTrait(file.path(traitDir, paste0(t, ".parquet"))) +}) +runs$traitA$categories +``` + +Those categories are a real baseline model — `Coding_UCSC`, +`Conserved_LindbladToh` and `Repressed_Hoffman`, each split into common and +low-frequency, plus `base` — with `ANNOT_0` as the target annotation under +test. + +```{r sldsc-pipeline} +sldscData <- SldscData( + annot = annotTable, + frq = frq, + traits = lapply(runs, function(r) list(single = list(r))) +) +result <- sldscPostprocessingPipeline( + sldscData, + targetCategories = "ANNOT_0" +) +as.data.frame(result$meta$enrichment) +``` + +The pipeline standardizes each trait's tau to Gazal tau\*, back-solves a +jackknife standard error for the enrichment statistic, and pools traits by +DerSimonian-Laird random-effects meta-analysis. `sldscSubsetMeta()` re-runs +the meta over a subset of traits without refitting anything: + +```{r sldsc-subset} +subset <- sldscSubsetMeta(result, subsetTraits = c("traitB", "traitC")) +unlist(subset$enrichment$ANNOT_0) +``` + +Each polyfun run may be a `single` target run or a `joint` one; supplying +both lets the pipeline report the target's enrichment from the single fit +alongside its coefficient from the joint fit. + +### The postprocessing steps + +`sldscPostprocessingPipeline()` is a wrapper over steps that are exported +individually, which is what you want when auditing a surprising number: + +```{r sldsc-steps} +computeSldscMRef(sldscData, mafCutoff = 0.05) # the M_ref that scales tau* +isBinarySldscAnnot(sldscData) # binary vs continuous +``` + +`computeSldscAnnotSd()` gives the per-annotation standard deviation that +turns tau into Gazal tau\*, `standardizeSldscTrait()` does that +standardisation for one trait's run, and `metaSldscRandom()` is the +DerSimonian-Laird pooling across traits. Running them yourself is the way to +see which of the three a strange tau\* came from. + +`getAnnotData()`, `getFrqData()`, `getAnnotCols()` and `getTraitRuns()` read +the corresponding parts of an `SldscData` back out. + +### LD scores from an existing reference + +`computeLdScores()` derives per-variant LD scores from an `LdEigen` or +`LdScore`, optionally stratified by annotation: + +```{r compute-ld-scores} +scores <- computeLdScores(ldEigenExample) +head(round(as.vector(scores[, 1]), 3)) +``` + +This is the same quantity `buildLdScore()` stores, reconstructed from the +eigendecomposition — `sum_i V[j,i]^2 d[i]^2` rather than `sum_k r^2_jk`. +The two agree, which is worth knowing when you have one object and need the +other's input. + +## Bridging the two tracks + +`h2EstimateToSldscTrait()` converts an `H2Estimate` into the same list shape +`readSldscTrait()` produces, so an in-package estimate can be meta-analysed +alongside polyfun runs: + +```{r bridge} +names(h2EstimateToSldscTrait(strat)) +``` + +## Next steps + +- [Molecular QTL enrichment](xqtl-enrichment.html) — the complementary + per-variant QTL/GWAS enrichment analysis. +- [QC for summary statistics](rss-qc.html) — preparing the GWAS side. + +# Session info + +```{r session-info} +sessionInfo() +``` diff --git a/vignettes/ld-infrastructure.Rmd b/vignettes/ld-infrastructure.Rmd new file mode 100644 index 00000000..ee588f4a --- /dev/null +++ b/vignettes/ld-infrastructure.Rmd @@ -0,0 +1,241 @@ +--- +title: "Working with LD references" +author: "pecotmr authors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Working with LD references} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +knitr::opts_chunk$set( + echo = TRUE, + message = FALSE, + warning = FALSE, + fig.width = 7, + fig.height = 4.5 +) +``` + +## Overview + +Almost everything else in pecotmr needs LD. Fine-mapping from summary +statistics needs it, RSS weight learning needs it, colocalization needs it, +and the heritability estimators are built on nothing else. The pipelines +handle it for you, so this vignette is about the layer underneath: loading +LD for a region, computing it from genotypes, checking it is usable, and +reducing a variant set that is too correlated to model. + +```{r load-packages} +library(pecotmr) +ldMeta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" +) +``` + +An LD reference is described by a **meta file**: one row per LD block, giving +the block's coordinates and the path to the genotype or correlation data +backing it. + +```{r meta} +read.delim(ldMeta, check.names = FALSE) +``` + +Paths are relative to the meta file, so a reference directory can be moved +without rewriting it. + +## Loading LD for a region + +`loadLdMatrix()` returns an `LdData` — a `GRanges` of the variants plus the +correlation matrix, or the genotypes to compute it from: + +```{r load} +region <- "chr22:10000000-19000000" +ld <- loadLdMatrix(ldMeta, region = region) +ld +R <- getCorrelation(ld) +dim(R) +``` + +Whether a correlation matrix or a genotype handle comes back depends on the +source. `returnGenotype = "auto"` (the default for genotype sources) returns +dosages and computes `R` on demand, which matters because a dense matrix for +a large region is far bigger than the genotypes it came from. + +`getVariantInfo()` gives the variants as a plain `GRanges`, which is what you +need to align summary statistics against the panel: + +```{r variant-info} +head(getVariantInfo(ld), 3) +``` + +**A region is not a block.** Loading a whole region returns one dense matrix +covering it. To get one matrix per LD block — which the block jackknife in +[heritability estimation](heritability.html) requires — address the blocks +individually. + +`region` also takes a vector, returning one `LdData` per entry — which is +how you get per-block LD without writing the loop yourself: + +```{r multi-region} +blocks <- read.delim(ldMeta, check.names = FALSE) +ldList <- loadLdMatrix( + ldMeta, + region = sprintf("chr22:%d-%d", blocks$start, blocks$end) +) +length(ldList) +``` + +### Sources without coordinates + +An LD meta file carries coordinates, so its blocks are addressed by `region`. +Other sources have no coordinates and are addressed by `block` index instead: + +- an **`ldInfo` table** — an `LD_file` column and optionally `SNP_file`, the + shape cTWAS's `LD_map` uses +- a **matrix** already in memory, or a list of them + +```{r by-block} +R2 <- computeLd(matrix(rnorm(100 * 10), 100, 10)) +loadLdMatrix(R2, block = 1) +``` + +Supplying both `region` and `block`, or neither, is an error — the source +determines which one applies. + +### Options + +| Argument | Effect | +|---|---| +| `returnGenotype` | `"auto"` gives dosages for genotype sources, `R` for pre-computed | +| `dropMonomorphic` | drop variants with no variation | +| `materializeGenotypes` | read dosages once and keep them, so later access does no file I/O | +| `maxVariants` / `seed` | randomly thin oversized blocks, reproducibly | + +```{r options} +thinned <- loadLdMatrix(ldMeta, region = region, maxVariants = 50, seed = 1) +length(thinned) +``` + +## Computing LD from genotypes + +`computeLd()` takes a dosage matrix and returns the correlation matrix: + +```{r compute} +set.seed(1) +X <- matrix(rnorm(100 * 20), 100, 20, dimnames = list(NULL, paste0("v", 1:20))) +X[, 5] <- X[, 4] + rnorm(100, sd = 0.01) # a near-duplicate pair +R2 <- computeLd(X) +dim(R2) +``` + +`method` selects the estimator — `"sample"` (default), `"population"`, or +`"gcta"` — and `shrinkage` applies shrinkage toward the identity. `backend` +can hand the work to SNPRelate or snpStats when those are installed. + +## Checking that LD is usable + +A correlation matrix estimated from finite samples is usually not positive +definite, and methods that invert it or take its eigendecomposition will +fail or return nonsense. `checkLd()` reports the diagnosis. Run it on the +real panel rather than the toy matrix above, which is well conditioned by +construction: + +```{r check} +diagnosis <- checkLd(R) +diagnosis[c( + "isPd", + "isPsd", + "minEigenvalue", + "nNegative", + "conditionNumber" +)] +``` + +That is what a real reference looks like: positive *semi*-definite but not +positive definite, with a smallest eigenvalue at rounding scale (`-7e-16`) +and a condition number around `1e9`. The negative value is floating-point +noise on a rank-deficient matrix, not structure — but it is exactly what +makes an unguarded `sqrt()` or `solve()` fail, and why LDER clamps +eigenvalues before forming its weights. + +`method = "shrink"` or `"eigenfix"` returns a repaired matrix instead of a +report: + +```{r check-fix} +fixed <- checkLd(R, method = "eigenfix") +c(before = diagnosis$minEigenvalue, after = checkLd(fixed$R)$minEigenvalue) +``` + +The smallest eigenvalue is lifted off zero, though on a matrix this +rank-deficient it stays tiny — repair makes the decomposition safe, it does +not restore rank that the reference panel never had. Repairing also changes +the data, so prefer a better-conditioned variant set where you can, which is +what the next section is for. + +## Reducing a correlated variant set + +Two variants in near-perfect LD carry the same information, and a design +containing both is singular. Three tools address that, differing in what +they optimise. + +`ldPruneByCorrelation()` drops variants until no pair exceeds a correlation +threshold, keeping the choice arbitrary among equivalents: + +```{r prune} +pruned <- ldPruneByCorrelation(X, corThres = 0.8) +ncol(pruned$X.new) +pruned$filter.id +``` + +It returns the reduced matrix and the retained column indices, so a parallel +table of statistics can be subset the same way. + +`ldClumpByScore()` keeps the *best-scoring* variant in each LD clump rather +than an arbitrary one — pass PIPs or −log10 p-values as `score` and it +behaves like PLINK's clumping: + +```{r clump, eval=FALSE} +ldClumpByScore(X, score = pips, chr = chrom, pos = position, r2 = 0.2) +``` + +`enforceDesignFullRank()` is the targeted version: rather than thresholding +everything, it drops variants iteratively until the design plus its +covariates reaches full column rank, and stops there. + +```{r full-rank} +Xdup <- cbind(X, dup = X[, 1]) # exactly collinear +dim(enforceDesignFullRank(Xdup, C = matrix(1, nrow(Xdup), 1))) +``` + +The `C` argument is the covariate matrix the design will sit alongside — +rank has to be assessed on the combined matrix, since a variant can be +independent of the other variants yet collinear with a covariate. +`strategy` chooses what to sacrifice: the most correlated variant, the +lowest-variance one, or the one least correlated with the response. + +## Aligning summary statistics to a panel + +The counterpart to all of this is on the summary-statistics side: variants +must exist in the panel, and their alleles must be oriented the same way. +`filterVariantsByLdReference()` and `mergeVariantInfo()` do that, and are +covered in the [QC vignette](rss-qc.html), where the motivation lives. + +## Next steps + +- [QC for summary statistics](rss-qc.html) — matching statistics to a panel. +- [Heritability](heritability.html) — `buildLdEigen()` / `buildLdScore()` + turn per-block LD into the statistics the h2 estimators consume. +- [Fine-mapping](fine-mapping.html) and [TWAS weights](twas-weights.html) — + the RSS methods that consume LD. + +# Session info + +```{r session-info} +sessionInfo() +``` diff --git a/vignettes/mash-pipeline.Rmd b/vignettes/mash-pipeline.Rmd new file mode 100644 index 00000000..4a6b57e8 --- /dev/null +++ b/vignettes/mash-pipeline.Rmd @@ -0,0 +1,313 @@ +--- +title: "Multivariate adaptive shrinkage across contexts with mash" +author: "pecotmr authors" +date: "`r Sys.Date()`" +output: rmarkdown::html_vignette +vignette: > + %\VignetteIndexEntry{Multivariate adaptive shrinkage across contexts with mash} + %\VignetteEngine{knitr::rmarkdown} + %\VignetteEncoding{UTF-8} +--- + +```{r setup, include=FALSE} +hasMash <- requireNamespace("mashr", quietly = TRUE) && + requireNamespace("flashier", quietly = TRUE) +knitr::opts_chunk$set( + echo = TRUE, + message = FALSE, + warning = FALSE, + fig.width = 7, + fig.height = 4.5, + eval = hasMash +) +``` + +```{r mash-missing, echo=FALSE, eval=!hasMash, results="asis"} +cat( + "**Note:** `mashr` and/or `flashier` are not installed, so the code", + "below is shown but not run." +) +``` + +## Overview + +A QTL measured in several contexts — tissues, cell types, conditions — is +usually not a set of independent experiments. Effects are shared, and an +effect that looks null in one context is often a real effect that context +was underpowered to see. + +[mash](https://github.com/stephenslab/mashr) learns the covariance structure +of effect sharing from the data and shrinks each variant's per-context +estimate toward it. `mashPipeline()` drives the whole fit; the chainable +steps behind it let you swap out any stage. + +The input is a named list of summary-statistic collections split into +**partitions**, each with a distinct job: + +| Partition | Role | +|---|---| +| `strong` | discovery variants; the data-driven covariances are learned here | +| `random` | unbiased background; the mixture weights are fit here | +| `null` | null variants; the residual correlation is estimated here | + +`strong` and `random` are required. `null` is optional and used only by the +residual-correlation estimators that need it. + +Fitting chunks below are run with `results = "hide"`: `mashr` and +`flashier` narrate their progress on stdout, which knitr cannot filter, so +each fit is split into a compute chunk and a display chunk. The code is +otherwise exactly what you would type. + +```{r load-packages} +library(pecotmr) +data(qtlSumStatsMulticontextExample) +ss <- qtlSumStatsMulticontextExample +ss +``` + +## The one-shot fit + +```{r mash-pipeline, results="hide"} +sumStatsList <- list(strong = ss, random = ss, null = ss) +fit <- mashPipeline(sumStatsList, alpha = 0, nPcs = 2L) +``` + +```{r mash-pipeline-show} +length(fit$U) +round(head(sort(fit$w, decreasing = TRUE), 5), 4) +``` + +`fit$U` is the prior covariance list and `fit$w` the estimated mixture +weights over it. A large weight on `null` is normal and healthy: most +variants are not QTLs. + +`alpha` must match the scale you are on: `alpha = 0` for effect sizes +(BETA/SE), `alpha = 1` for Z-scores. `inputScale` controls which pair is +extracted from the sumstats and defaults to `"auto"` — BETA + SE when every +entry carries both, otherwise Z with unit standard errors. + +## Residual correlation + +Conditions measured on overlapping samples have correlated residuals, and +mash needs an estimate of that correlation (`Vhat`) to avoid reading shared +noise as shared signal. `residualCorrelationMethod` chooses the estimator: + +| Value | Estimator | Needs | +|---|---|---| +| `"identity"` (default) | no residual correlation | — | +| `"simple"` | `mashr::estimate_null_correlation_simple()` | `null` | +| `"simpleSpecific"` | nearest PD correlation of `cov(nullZ)` | `null` | +| `"corshrink"` | adaptive shrinkage of the null correlation | `null`, CorShrink | +| `"mle"` | EM refinement against the prior | `random`, `priorCovariances` | + +The default is `"identity"` because it always works, **not** because it is +the best choice. Multi-context QTL data is the overlapping-sample case par +excellence — the same donors appear in every context — so the identity +assumption is usually wrong. Prefer a data-driven estimate whenever you have +a null set: + +```{r mash-vhat, results="hide"} +fitSimple <- mashPipeline( + sumStatsList, + alpha = 0, + nPcs = 2L, + residualCorrelationMethod = "simple" +) +``` + +```{r mash-vhat-show} +round(head(sort(fitSimple$w, decreasing = TRUE), 5), 4) +``` + +Supplying a `null` partition while leaving the default in place reports that +the partition is going unused, since that combination is more often an +oversight than an intent. + +You can also skip estimation entirely and pass a `Vhat` computed elsewhere — +useful when it was estimated on a larger reference and shipped as a static +artefact: + +```{r mash-vhat-supplied, eval=FALSE} +mashPipeline(sumStatsList, alpha = 0, residualCorrelation = myVhat) +``` + +## The chain, step by step + +`mashPipeline()` is a wrapper over four steps. Take them apart when you want +to reuse an intermediate, try several priors against one `Vhat`, or compute +posteriors for a set other than the one you fit on. + +```{r mash-chain, results="hide"} +vhat <- mashResidualCorrelation(sumStatsList, alpha = 0, method = "simple") +prior <- mashPriorCovariances(sumStatsList, alpha = 0, vhat = vhat, nPcs = 2L) +model <- mashModelFit( + sumStatsList, + alpha = 0, + priorCovariances = prior, + vhat = vhat +) +``` + +```{r mash-chain-show} +class(model) +``` + +`mashPriorCovariances()` returns `list(U, w, loglik)`, while +`mashCovarianceComponents()` returns a bare covariance list. Either can be +handed to any consumer — the wrapper is unwrapped for you, so there is no +need to reach for `$U`. + +`mashModelFit()` returns a `mashr` model object. That is not the same thing +as the `MashPrior` class, which packages a prior for use as a TWAS weight +method; see [TWAS weights](twas-weights.html). + +## Posteriors + +`mashPosterior()` applies the fitted model to a target set. Fitting on +`random` and computing posteriors on `strong` is the standard split — the +weights should not be learned from the same variants they are applied to. + +```{r mash-posterior, results="hide"} +post <- mashPosterior(model, ss, alpha = 0, vhat = vhat) +``` + +```{r mash-posterior-show} +names(post) +dim(post$PosteriorMean) +``` + +| Matrix | Meaning | +|---|---| +| `PosteriorMean` / `PosteriorSD` | shrunk effect and its uncertainty | +| `lfsr` | local false sign rate — the quantity to threshold on | +| `lfdr` | local false discovery rate | +| `NegativeProb` | posterior probability the effect is negative | +| `PosteriorCov` | per-variant across-context covariance | + +`lfsr` is the usual significance measure here: it asks whether the *sign* of +an effect is confidently known, which is a more honest question than whether +it is exactly zero. + +```{r mash-lfsr} +# Variants significant in at least one context at lfsr < 0.05 +sum(apply(post$lfsr, 1, min) < 0.05) +``` + +## Choosing the covariance components + +The data-driven part of the prior is built from `components` and then +refined by an `engine`: + +```{r mash-components, eval=FALSE} +mashPriorCovariances( + sumStatsList, + alpha = 0, + vhat = vhat, + components = c("canonical", "pca", "flash", "flashNonneg"), + engine = "cov_ed", # or "ud" / "ud_ted" (udr) + nPcs = 2L +) +``` + +`"cov_ed"` is the default and is mashr's own extreme deconvolution. The +`udr` engines are opt-in and have known numerical issues; `"ud_ted"` +additionally assumes i.i.d. (Z-scale) data. Their dominant cost is +`udControl$n_unconstrained` (default 50), which is worth cutting sharply +when you have few conditions. + +To bypass the covariance chain entirely and fit weights against a prior you +already have: + +```{r mash-prior-supplied, eval=FALSE} +mashPipeline(sumStatsList, alpha = 0, priorCovariances = myU) +``` + +## Posterior contrasts and feature scores + +Posterior means answer "how big is the effect in each context". A different +question — "which contexts does this feature deviate in, relative to its own +average" — is what the contrast layer computes. + +```{r mash-contrast, results="hide"} +data(mashPosteriorExample) +p <- mashPosteriorExample +contrast <- mashPosteriorContrast( + p$posterior$PosteriorMean, + p$posterior$PosteriorCov, + p$orig$bhat +) +scores <- calculateFeatureScores(contrast) +``` + +```{r mash-contrast-show} +scores +``` + +Each row is one condition's meta-analysed deviation score across features — +a per-context summary of how distinctive that context's effects are. The +bundled example is a brain cell-type panel, so the conditions are cell +types (`Ast`, `Exc`, `Mic`, ...) plus the `ALL` pooled column. + +## Three ways to score a feature + +`calculateFeatureScores()` is one of three scoring routes over the same +contrast result, and they answer different questions: + +```{r scores-three} +# 1. meta-analysed deviation z, across features (shown above) +head(scores, 3) + +# 2. the fraction of features whose deviation is significant +nSignificantScore(contrast, pCutoff = 1e-5) +``` + +`nSignificantScore()` asks *how often* a condition deviates rather than *how +strongly* — a condition can carry a large mean deviation driven by a handful +of features, or a modest one that is consistent across many, and only the +second is captured here. + +The third route brings fine-mapping in. `scoreFromCs()` restricts to the +lead variant of each credible set, so the score reflects deviation at +variants that are plausibly causal rather than at whatever tagged them: + +```{r score-cs} +scoreFromCs(p$fineMapping, contrast, condition = "Exc") +``` + +It takes the least-significant credible-set lead and reports the largest +pairwise |mean|/se there — a deliberately conservative summary, since one +strong credible set should not carry a condition on its own. + +The contrast design itself is built from `makePairwiseContrastCol()`, which +sets +1 and −1 for a pair of conditions in a zero vector, and +`fitMashContrast()`, which fits one feature's contrast. `mashPosteriorContrast()` +calls both across all features and pairs, so you only need them directly when +building a non-pairwise design. + +## Utilities + +The mash track ships a set of helpers for getting real data into shape: + +| Function | Use | +|---|---| +| `mashInput()` | build the `(strong, random, null)` matrices from fine-mapping output | +| `sanitizeMashData()` | replace `NaN`/`Inf` in `bhat`/`sbhat` with safe values | +| `filterInvalidSummaryStat()` | drop rows mash cannot use | +| `mergeMashData()` / `sliceMashData()` | combine or subset the matrix bundles | +| `mashRandNullSample()` | draw the random/null partitions | +| `filterMixtureComponents()` | drop components with negligible weight | +| `metaAnalysisPerCondition()` | per-condition fixed-effect meta-analysis | +| `updateMashModelCov()` | swap a fitted model's covariance list | + +## Next steps + +- [Building QtlSumStats objects](constructing-sumstats.html) — assembling + the multi-context input. +- [TWAS weights](twas-weights.html) — where a mash prior is consumed, via + `MashPrior` and mr.mash. + +# Session info + +```{r session-info} +sessionInfo() +``` diff --git a/vignettes/rss-qc.Rmd b/vignettes/rss-qc.Rmd index 51ee849d..51e5651c 100644 --- a/vignettes/rss-qc.Rmd +++ b/vignettes/rss-qc.Rmd @@ -88,6 +88,87 @@ A non-zero `mafCutoff` requires every entry to carry a `MAF` mcol; non-zero with a non-zero cutoff will produce an error - if you don't want a filter to run, leave its cutoff at the default value of 0. +## The pieces QC is built from + +`summaryStatsQc()` orchestrates the steps below. Each is exported, because +the same operations come up outside a full QC run — preparing a variant list, +auditing why something was dropped, or applying one check without the rest. + +### Classifying variants + +Allele strings decide how a variant is handled: indels cannot be matched to a +panel the same way SNPs are, and strand-ambiguous SNPs need care. + +```{r classify} +ids <- c( + "chr22:10685239:C:T", + "chr22:10761227:G:A", + "chr22:11285239:CT:C", + "chr22:11500000:A:T" +) +classifyVariantType(ids) +``` + +### Matching a variant list to an LD panel + +`filterVariantsByLdReference()` keeps only variants the panel actually +carries, and reports how many it dropped. It returns both the surviving IDs +and their positions in the input, so a parallel table can be subset the same +way. + +```{r filter-ld} +ldMeta <- system.file( + "extdata", + "ld_reference", + "ld_meta_file.tsv", + package = "pecotmr" +) +kept <- filterVariantsByLdReference(ids, ldMeta) +kept$data +kept$idx +``` + +`keepIndel = FALSE` additionally drops indels, which is what an +RSS method wanting a SNP-only design needs: + +```{r filter-ld-snps} +filterVariantsByLdReference(ids, ldMeta, keepIndel = FALSE)$data +``` + +### Reconciling two variant tables + +`mergeVariantInfo()` matches two variant sets while allowing for flipped +alleles — the second table is re-oriented to the first rather than treated as +a different variant: + +```{r merge-variants} +panel <- data.frame( + chrom = "chr22", pos = c(10685239, 10761227), + ref = c("C", "G"), alt = c("T", "A") +) +sumstats <- data.frame( + chrom = "chr22", pos = c(10685239, 10761227), + ref = c("T", "G"), alt = c("C", "A") # first variant is flipped +) +mergeVariantInfo(panel, sumstats) +``` + +The flipped variant comes back on the panel's orientation. `all = FALSE` +returns only the re-oriented second set instead of the union. + +### Applying one mismatch check + +`ldMismatchQc()` is the LD-mismatch step on its own, taking z-scores plus +either a correlation matrix (`R`) or genotypes (`X`): + +```{r ld-mismatch, eval=FALSE} +ldMismatchQc(zScore = z, R = ldMatrix, nSample = 10000, method = "slalom") +``` + +and `autoDecision()` is the helper that reads credible-set structure to +decide whether a flagged variant should be imputed or dropped — the choice +`summaryStatsQc()` otherwise makes for you. + ## Allele-flip QC: the SuSiE kriging prefilter `alleleFlipKriging = TRUE` enables an optional prefilter that runs **before** @@ -202,7 +283,7 @@ gws_qcd <- summaryStatsQc( ## Next steps `QtlSumStats` and `GwasSumStats` are direct inputs to `fineMappingPipeline()`, -`twasWeightsPipeline()` (`QtlSumStats` only) and `colocBoostPipeline()`— see +`twasWeightsPipeline()` (`QtlSumStats` only) and `colocboostPipeline()`— see the *Fine-mapping with pecotmr*, *Learning TWAS weights with pecotmr* and *Multi-trait colocalization with ColocBoost* vignettes. diff --git a/vignettes/twas-weights.Rmd b/vignettes/twas-weights.Rmd index bab67508..8415431f 100644 --- a/vignettes/twas-weights.Rmd +++ b/vignettes/twas-weights.Rmd @@ -188,6 +188,86 @@ twasWeightsPipeline( ) ``` +## Calling a weight method directly + +Each `methods =` value dispatches to an exported function, and those +functions are usable on their own. Reach for one when you want to fit a +single model to a matrix you already have — tuning a penalty, comparing +methods outside the pipeline, or debugging a method that behaves oddly on +your data. + +The individual-level methods take `X` (genotypes) and `y` (phenotype) and +return a weight vector: + +```{r direct-method} +set.seed(1) +n <- 200 +p <- 30 +X <- matrix(rnorm(n * p), n, p, dimnames = list(NULL, paste0("v", 1:p))) +y <- as.vector(X %*% c(rep(0.4, 3), rep(0, p - 3)) + rnorm(n)) + +w <- lassoWeights(X = X, y = y) +c(length = length(w), nonzero = sum(w != 0)) +``` + +The families, and the `methods =` name each answers to: + +| Family | `methods =` | Function | +|---|---|---| +| Penalized regression | `lasso`, `enet`, `mcp`, `scad`, `l0learn` | `lassoWeights()`, `enetWeights()`, … | +| Bayesian alphabet | `bayesA` … `bayesR`, `bLasso` | `bayesAWeights()`, `bLassoWeights()`, … | +| Dirichlet process regression | `dprVb`, `dprGibbs`, `dprAdaptiveGibbs` | `dprVbWeights()`, `dprGibbsWeights()`, … | +| External PRS methods | `prsCs` (sumstats input only) | `prsCs()`, `sdpr()`, `lassosumRss()` | +| mr.mash / mr.ash | `mrmash`, `mrash` | `mrmashWeights()`, `mrashWeights()` | +| SuSiE family | `susie`, `susieInf`, `susieAsh`, `mvsusie`, `fsusie` | `susieWeights()`, `mvsusieWeights()`, … | + +Every token is camelCase, matching the function names. Snake_case spellings +are not accepted: `bayes_r`, `dpr_vb` and `susie_inf` all error with the list +of known tokens. + +Every family has an RSS counterpart taking summary statistics and an LD +matrix instead of `X`/`y` — `lassosumRssWeights()`, `mcpRssWeights()`, +`susieRssWeights()`, and so on. Those are what +`twasWeightsPipeline()` calls when the input is a `QtlSumStats`. + +`prsCs()`, `sdpr()` and `lassosumRss()` are exported alongside their +`*Weights()` adapters because they return more than the coefficient vector. +`sdpr()` also gives a heritability estimate (`h2`), `lassosumRss()` the whole +regularization path (`beta` is variants x lambda, plus the `lambda` grid and +per-fit `loss`), and `prsCs()` the posterior shrinkage parameters (`psiEst`, +`sigmaEst`, `phiEst`). The adapters reduce each of those to the weights the +pipeline consumes, so reach for the raw function when you want the +diagnostics rather than just the weights. + +The mr.mash methods need prior covariance matrices, built by +`buildMrmashPriorMatrices()` from components like `computeCovDiag()` and +`computeCovFlash()`. + +## Cross-validation, ensembling and prediction + +The pipeline's `ensemble` method is not a model of its own — it is a weighted +combination of the others, with the weights chosen by cross-validation. +Those steps are exported too: + +- `twasWeightsCv()` runs the cross-validation that scores each method. +- `learnTwasWeights()` fits one method across CV folds. +- `combineTwasWeights()` forms the ensemble from per-method weights. +- `estimateSparsity()` reports how sparse a fitted weight vector is. + +Once you have weights, `twasPredict()` applies them to a genotype matrix. +It takes a *named list* of weight vectors, with names ending in `_weights`, +and returns one predicted column per entry: + +```{r predict} +pred <- twasPredict(X, list(gene1_weights = w)) +names(pred) +round(cor(as.vector(pred[[1]]), y), 3) +``` + +That correlation is the in-sample prediction accuracy — on real data you +would want the cross-validated version from `twasWeightsCv()` instead, since +in-sample accuracy is optimistic by construction. + ## Common parameters ```{r tw-params, eval=FALSE} diff --git a/vignettes/twas-zscore.Rmd b/vignettes/twas-zscore.Rmd index 4492a1ea..091bbec7 100644 --- a/vignettes/twas-zscore.Rmd +++ b/vignettes/twas-zscore.Rmd @@ -139,6 +139,16 @@ Accepted values for `combineMethods`: `acat`, `hmp`, `bonferroni`, `fisher`, `stouffer`, `invchisq`, `gbj`, `bj`, `hc`, `ghc`, `minp`, `gbj_omni`, `aspu`, `gates` (see `?combinePValues`). +The per-tuple p-value itself comes from `waldTestPval()`, which is exported +so the same test can be applied to any effect estimate and standard error: + +```{r wald} +waldTestPval(beta = 2.5, se = 0.8, n = 10000) +``` + +`n` sets the degrees of freedom, so a small study gives a more conservative +p-value than the normal approximation would. + ## LD-sketch consistency Both `twasWeights` and `fineMappingResult` carry an `ldSketch` slot.