diff --git a/.github/recipe/recipe.yaml b/.github/recipe/recipe.yaml index 21666705..a30c6e24 100644 --- a/.github/recipe/recipe.yaml +++ b/.github/recipe/recipe.yaml @@ -24,7 +24,6 @@ requirements: - ${{ compiler('cxx') }} host: - bioconductor-biocparallel - - bioconductor-biostrings - bioconductor-genomicranges - bioconductor-iranges - bioconductor-qvalue @@ -43,6 +42,7 @@ requirements: - r-coda - r-coloc - r-colocboost + - r-corshrink - r-cpp11 - r-cpp11armadillo - r-ctwas @@ -59,6 +59,7 @@ requirements: - r-mashr - r-matrix - r-matrixstats + - r-metafor - r-mr.ash.alpha - r-mr.mashr - r-mvsusier @@ -81,6 +82,7 @@ requirements: - r-tibble - r-tictoc - r-tidyr + - r-udr - r-vctrs - r-vroom - r-xgboost @@ -105,6 +107,7 @@ requirements: - r-coda - r-coloc - r-colocboost + - r-corshrink - r-cpp11 - r-cpp11armadillo - r-ctwas @@ -121,6 +124,7 @@ requirements: - r-mashr - r-matrix - r-matrixstats + - r-metafor - r-mr.ash.alpha - r-mr.mashr - r-mvsusier @@ -143,6 +147,7 @@ requirements: - r-tibble - r-tictoc - r-tidyr + - r-udr - r-vctrs - r-vroom - r-xgboost diff --git a/.gitignore b/.gitignore index 5a7c2dee..e3cbe05c 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,6 @@ src/*.o src/*.gcda src/*.so src/*.dylib -src/Makevars **/.ipynb_checkpoints .Rproj.user **/.DS_Store diff --git a/DESCRIPTION b/DESCRIPTION index 3764da0e..7a171340 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -28,6 +28,7 @@ Imports: dplyr, magrittr, matrixStats, + metafor, methods, purrr, quadprog, @@ -48,6 +49,8 @@ Suggests: bigsnpr, bigstatsr, coda, + CorShrink, + ctwas, flashier, fsusieR, GBJ, @@ -57,7 +60,6 @@ Suggests: igraph, knitr, L0Learn, - lassosum, mashr, mr.mashr, mvsusieR, @@ -76,18 +78,21 @@ Suggests: SNPRelate, snpStats, testthat, + udr, VariantAnnotation Remotes: + kkdey/CorShrink, stephenslab/fsusieR, stephenslab/mvsusieR, stephenslab/susieR, + stephenslab/udr, + xinhe-lab/multigroup_ctwas, LinkingTo: cpp11, cpp11armadillo NeedsCompilation: yes VignetteBuilder: knitr Config/roxygen2/version: 8.0.0 -RoxygenNote: 7.3.3 Collate: 'AllGenerics.R' 'GenotypeHandle.R' @@ -113,16 +118,20 @@ Collate: 'TwasWeightsEntry.R' 'causalInferencePipeline.R' 'colocPipeline.R' + 'qtlSumStats.R' 'colocboostPipeline.R' 'cpp11.R' + 'credibleSetSummary.R' 'crossValidation.R' 'ctwasPipeline.R' 'deprecated.R' 'exampleData.R' + 'gwasSumStats.R' 'fineMappingPipeline.R' 'fineMappingWrappers.R' + 'fsusieAccessors.R' 'genotypeIo.R' - 'gwasSumStats.R' + 'getLbf.R' 'h2Annotations.R' 'h2EstimationWrappers.R' 'jointEngine.R' @@ -130,11 +139,12 @@ Collate: 'ld.R' 'sumstatsQc.R' 'variantId.R' - 'qtlSumStats.R' 'manifestLoaders.R' 'mashPipeline.R' 'mashWrapper.R' + 'overlapTopLoci.R' 'pvalCombine.R' + 'qtlAssociationPostprocess.R' 'qtlEnrichmentPipeline.R' 'regularizedRegressionWrappers.R' 'relatednessQc.R' diff --git a/NAMESPACE b/NAMESPACE index feea5479..c0f1ef68 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -6,6 +6,7 @@ S3method(postprocessFinemappingFit,susiF) S3method(postprocessFinemappingFit,susie) S3method(postprocessFinemappingFit,susieInf) S3method(postprocessFinemappingFit,susieRss) +export(.fullFitColumns) export(AnnotationMatrix) export(CtwasResult) export(CtwasResultEntry) @@ -39,7 +40,7 @@ export(bayesLWeights) export(bayesNWeights) export(bayesRWeights) export(buildMrmashPriorMatrices) -export(buildTopLoci) +export(calculateFeatureScores) export(causalInferencePipeline) export(checkLd) export(classifyVariantType) @@ -89,6 +90,8 @@ export(fitMvsusie) export(fitMvsusieRss) export(fitSusieInfThenSusieRss) export(formatFinemappingOutput) +export(fsusieAffectedRegions) +export(fsusieCredibleBand) export(fsusieGetCs) export(fsusieWeights) export(fsusieWrapper) @@ -98,11 +101,13 @@ export(getAnnotData) export(getAnnotationMeta) export(getAnnotations) export(getBaseline) +export(getBeta) export(getBlockMetadata) export(getBlocks) export(getCandidates) export(getContexts) export(getCorrelation) +export(getCredibleSetSummary) export(getCs) export(getCtwasMetaData) export(getCtwasParam) @@ -123,6 +128,7 @@ export(getGenotypeHandle) export(getGenotypes) export(getH2) export(getInSample) +export(getLbf) export(getLdBlocks) export(getLdMatrixList) export(getLdScoreWeights) @@ -136,6 +142,7 @@ export(getMixtureWeights) export(getN) export(getNRef) export(getNSamples) +export(getP) export(getPath) export(getPgenPtr) export(getPhenotypeCovariates) @@ -149,9 +156,11 @@ export(getRefVariantInfo) export(getRegion) export(getResidualizedGenotypes) export(getResidualizedPhenotypes) +export(getSE) export(getSampleIds) export(getScaleResiduals) export(getScoreStats) +export(getSignificantQtls) export(getSnpIdx) export(getSnpInfo) export(getSnpRanges) @@ -165,6 +174,7 @@ export(getSusieResult) export(getTauBlocks) export(getTopLoci) export(getTraitNames) +export(getTraitPosition) export(getTraitRun) export(getTraitRuns) export(getTraits) @@ -213,8 +223,15 @@ export(loadStudyLd) export(loadTsvRegion) export(loadTwasWeights) export(makePairwiseContrastCol) +export(mashCovarianceComponents) +export(mashInput) +export(mashModelFit) export(mashPipeline) +export(mashPosterior) +export(mashPosteriorContrast) +export(mashPriorCovariances) export(mashRandNullSample) +export(mashResidualCorrelation) export(matchRefPanel) export(mcpRssWeights) export(mcpWeights) @@ -222,7 +239,7 @@ export(mergeCtwasBoundaryRegions) export(mergeMashData) export(mergeSusieCs) export(mergeVariantInfo) -export(metaAnalysisPerCell) +export(metaAnalysisPerCondition) export(metaSldscRandom) export(mrAshRssWeights) export(mrashWeights) @@ -232,8 +249,10 @@ export(mrmashWrapper) export(multivariateAnalysisPipeline) export(mvsusieRssWeights) export(mvsusieWeights) +export(nSignificantScore) export(nSnps) export(normalizeVariantId) +export(overlapTopLoci) export(parseCsCorr) export(parseRegion) export(parseVariantId) @@ -241,8 +260,10 @@ export(penalizedRss) export(postprocessFinemappingFits) export(prsCs) export(prsCsWeights) +export(qtlAssociationPostprocess) export(qtlEnrichment) export(qtlEnrichmentPipeline) +export(qtlSumStatsFromBetaMatrix) export(qtlSumStatsFromZMatrix) export(raiss) export(readAfreq) @@ -260,6 +281,7 @@ export(rssAnalysisPipeline) export(sanitizeMashData) export(scadRssWeights) export(scadWeights) +export(scoreFromCs) export(screenCtwasRegions) export(sdpr) export(sdprWeights) @@ -307,15 +329,19 @@ exportMethods(colocboostPipeline) exportMethods(computeLdScores) exportMethods(estimateH2) exportMethods(fineMappingPipeline) +exportMethods(fsusieAffectedRegions) +exportMethods(fsusieCredibleBand) exportMethods(getAf) exportMethods(getAnnotCols) exportMethods(getAnnotData) exportMethods(getAnnotationMeta) exportMethods(getAnnotations) +exportMethods(getBeta) exportMethods(getBlockMetadata) exportMethods(getBlocks) exportMethods(getContexts) exportMethods(getCorrelation) +exportMethods(getCredibleSetSummary) exportMethods(getCs) exportMethods(getCtwasParam) exportMethods(getCvFits) @@ -335,6 +361,7 @@ exportMethods(getGenotypeHandle) exportMethods(getGenotypes) exportMethods(getH2) exportMethods(getInSample) +exportMethods(getLbf) exportMethods(getLdBlocks) exportMethods(getLdMatrixList) exportMethods(getLdScoreWeights) @@ -348,6 +375,7 @@ exportMethods(getMixtureWeights) exportMethods(getN) exportMethods(getNRef) exportMethods(getNSamples) +exportMethods(getP) exportMethods(getPath) exportMethods(getPgenPtr) exportMethods(getPhenotypeCovariates) @@ -360,9 +388,11 @@ exportMethods(getRefPanel) exportMethods(getRegion) exportMethods(getResidualizedGenotypes) exportMethods(getResidualizedPhenotypes) +exportMethods(getSE) exportMethods(getSampleIds) exportMethods(getScaleResiduals) exportMethods(getScoreStats) +exportMethods(getSignificantQtls) exportMethods(getSnpIdx) exportMethods(getSnpInfo) exportMethods(getSnpRanges) @@ -375,6 +405,7 @@ exportMethods(getSusieFit) exportMethods(getTauBlocks) exportMethods(getTopLoci) exportMethods(getTraitNames) +exportMethods(getTraitPosition) exportMethods(getTraitRun) exportMethods(getTraitRuns) exportMethods(getTraits) @@ -386,6 +417,8 @@ exportMethods(getWeights) exportMethods(getZ) exportMethods(hasGenotypes) exportMethods(nSnps) +exportMethods(overlapTopLoci) +exportMethods(qtlAssociationPostprocess) exportMethods(readAnnotations) exportMethods(readGenotypes) exportMethods(resolveWeights) @@ -432,6 +465,7 @@ importFrom(dplyr,filter) importFrom(dplyr,group_by) importFrom(dplyr,if_else) importFrom(dplyr,inner_join) +importFrom(dplyr,matches) importFrom(dplyr,mutate) importFrom(dplyr,pull) importFrom(dplyr,rename) @@ -441,6 +475,7 @@ importFrom(dplyr,slice) importFrom(dplyr,summarise) importFrom(magrittr,"%>%") importFrom(matrixStats,colSds) +importFrom(metafor,rma) importFrom(methods,as) importFrom(methods,is) importFrom(methods,new) diff --git a/R/AllClasses.R b/R/AllClasses.R index 37e2d2ee..bec58385 100644 --- a/R/AllClasses.R +++ b/R/AllClasses.R @@ -32,7 +32,9 @@ NULL #' \code{GwasSumStats}) inherit from \code{DFrame} and share the #' \code{ldSketch} / \code{genome} / \code{qcInfo} slots. #' @slot ldSketch The \code{GenotypeHandle} the QC pipeline harmonized -#' against. Required: \code{summaryStatsQc()} sets it. +#' against, or \code{NULL}. Optional: LD-free workflows (e.g. mash, which +#' operates across conditions per variant) carry \code{NULL}; pipelines that +#' need LD validate its presence when they consume the collection. #' @slot genome Character, genome build label. #' @slot qcInfo A \code{list} recording which QC steps ran. Empty #' \code{list()} on construction; populated by \code{summaryStatsQc()} @@ -44,7 +46,7 @@ NULL setClass("SumStatsBase", contains = c("VIRTUAL", "DFrame"), representation( - ldSketch = "GenotypeHandle", + ldSketch = "ANY", genome = "character", qcInfo = "list" )) @@ -99,6 +101,22 @@ setMethod("getZ", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$Z) #' @export setMethod("getN", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$N) +# getP / getBeta / getSE are first-class alongside getZ / getN: they read the +# optional P / BETA / SE mcols and return NULL when the entry does not carry +# them (DataFrame `$` semantics), so a p-value-primary sumstats (e.g. TensorQTL +# cis output) is an equal citizen to a Z-primary GWAS sumstats. +#' @rdname getP +#' @export +setMethod("getP", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$P) + +#' @rdname getBeta +#' @export +setMethod("getBeta", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$BETA) + +#' @rdname getSE +#' @export +setMethod("getSE", "SumStatsBase", function(x, ...) mcols(getSumStats(x, ...))$SE) + #' @rdname getMaf #' @export setMethod("getMaf", "SumStatsBase", function(x, ...) { @@ -177,13 +195,14 @@ setGeneric(".fmrSelectEntry", function(x, ...) standardGeneric(".fmrSelectEntry" #' @export setMethod("getCs", "FineMappingResultBase", function(x, study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, coverage = 0.95, ...) { + region = NULL, coverage = 0.95, minPurity = NULL, ...) { # Selectors pinning one entry -> that entry's bare credible-set table; no / # partial selectors -> aggregate every matching entry's credible sets, # prefixed with the row identity (study/context/trait/region_id/method). + # `minPurity` is an independent CS-quality filter, orthogonal to coverage. .fmrAggregateView(x, study = study, context = context, trait = trait, method = method, region = region, - perEntry = function(e) getCs(e, coverage = coverage)) + perEntry = function(e) getCs(e, coverage = coverage, minPurity = minPurity)) }) #' @rdname getTopLoci @@ -191,10 +210,11 @@ setMethod("getCs", "FineMappingResultBase", setMethod("getTopLoci", "FineMappingResultBase", function(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, study = NULL, context = NULL, trait = NULL, method = NULL, - region = NULL, ...) { + region = NULL, minPurity = NULL, ...) { type <- match.arg(type) # type = "GRanges" can only be honored for a single pinned entry; the - # aggregate (identity-prefixed) form is data.frame-only. + # aggregate (identity-prefixed) form is data.frame-only. `minPurity` is an + # independent CS-quality filter, orthogonal to the pip `signalCutoff`. if (type == "GRanges") { sel <- tryCatch( .fmrSelectEntry(x, study = study, context = context, trait = trait, @@ -204,7 +224,8 @@ setMethod("getTopLoci", "FineMappingResultBase", stop("getTopLoci: aggregating across multiple entries requires ", "type = 'data.frame'.") } - return(getTopLoci(sel, type = "GRanges", signalCutoff = signalCutoff)) + return(getTopLoci(sel, type = "GRanges", signalCutoff = signalCutoff, + minPurity = minPurity)) } # data.frame: bare per-variant table when selectors pin one entry, else the # per-variant tables of every matching row stacked with row identity @@ -212,7 +233,8 @@ setMethod("getTopLoci", "FineMappingResultBase", .fmrAggregateView(x, study = study, context = context, trait = trait, method = method, region = region, perEntry = function(e) getTopLoci(e, type = "data.frame", - signalCutoff = signalCutoff)) + signalCutoff = signalCutoff, + minPurity = minPurity)) }) #' @rdname getMarginalEffects @@ -233,6 +255,11 @@ setMethod("getMarginalEffects", "FineMappingResultBase", #' @export setMethod("getRegion", "FineMappingResultBase", function(x, ...) .getRegionColumn(x)) +#' @rdname getTraitPosition +#' @export +setMethod("getTraitPosition", "FineMappingResultBase", + function(x, ...) .getTraitPosColumn(x)) + #' @rdname getSusieFit #' @export setMethod("getSusieFit", "FineMappingResultBase", diff --git a/R/AllGenerics.R b/R/AllGenerics.R index 1e92dab8..722243da 100644 --- a/R/AllGenerics.R +++ b/R/AllGenerics.R @@ -133,6 +133,37 @@ setGeneric("getZ", function(x, ...) standardGeneric("getZ")) #' @export setGeneric("getN", function(x, ...) standardGeneric("getN")) +#' @title Get Association P-values +#' @description Extract the association p-value vector from a +#' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity +#' tuple. Part of the first-class summary-statistic column set alongside +#' \code{\link{getZ}} / \code{\link{getBeta}} / \code{\link{getSE}}. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param ... Class-specific selection arguments. +#' @return Numeric vector of p-values, or \code{NULL} if not available. +#' @export +setGeneric("getP", function(x, ...) standardGeneric("getP")) + +#' @title Get Marginal Effect Sizes +#' @description Extract the marginal effect-size (beta) vector from a +#' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity +#' tuple. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param ... Class-specific selection arguments. +#' @return Numeric vector of effect sizes, or \code{NULL} if not available. +#' @export +setGeneric("getBeta", function(x, ...) standardGeneric("getBeta")) + +#' @title Get Effect-Size Standard Errors +#' @description Extract the effect-size standard-error vector from a +#' \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity +#' tuple. +#' @param x A \code{GwasSumStats} or \code{QtlSumStats} object. +#' @param ... Class-specific selection arguments. +#' @return Numeric vector of standard errors, or \code{NULL} if not available. +#' @export +setGeneric("getSE", function(x, ...) standardGeneric("getSE")) + #' @title Get Minor Allele Frequencies #' @description Extract MAF vector from a GwasSumStats object. #' @param x A \code{GwasSumStats} or \code{QtlDataset} object. @@ -165,6 +196,31 @@ setGeneric("getAf", function(x, ...) standardGeneric("getAf")) #' @export setGeneric("nSnps", function(x, ...) standardGeneric("nSnps")) +#' @title Hierarchical Multiple-Testing Correction for cis-QTL Association +#' @description Apply hierarchical (local per-gene + global across-gene) +#' multiple-testing correction to a per-gene \code{QtlSumStats} of cis-QTL +#' association statistics (one row per gene/trait), returning the same object +#' enriched with the corrected-statistic columns. See +#' \code{\link{qtlAssociationPostprocess}}. +#' @param x A \code{QtlSumStats}. +#' @param ... Correction arguments. +#' @return The input \code{QtlSumStats} with added correction columns. +#' @export +setGeneric("qtlAssociationPostprocess", + function(x, ...) standardGeneric("qtlAssociationPostprocess")) + +#' @title Extract Significant cis-QTL Variants +#' @description Derive the significant variants under a given correction method +#' and FDR threshold from a \code{QtlSumStats} enriched by +#' \code{\link{qtlAssociationPostprocess}} (significance is computed on demand, +#' never stored). +#' @param x A \code{QtlSumStats}. +#' @param ... Selection arguments (\code{method}, \code{threshold}). +#' @return A \code{GRanges} (or list of GRanges) of the significant variants. +#' @export +setGeneric("getSignificantQtls", + function(x, ...) standardGeneric("getSignificantQtls")) + #' @title Subset by Chromosome #' @description Extract a chromosome-specific subset of a GwasSumStats object. #' @param x A \code{GwasSumStats} object. @@ -647,6 +703,23 @@ setGeneric("getTraits", function(x) standardGeneric("getTraits")) #' @export setGeneric("getRegion", function(x, ...) standardGeneric("getRegion")) +#' @title Get Per-Row Trait Positions +#' @description Return the molecular feature's OWN genomic coordinates (the gene +#' / peak range; TSS = \code{start()}) for each row of a per-tuple collection, +#' as a \code{GRanges} with one range per row. Distinct from +#' \code{\link{getRegion}} (the fine-mapping window for a +#' \code{FineMappingResult}): the true trait position cannot be inferred from +#' summary statistics, so it is threaded from the QtlDataset \code{rowRanges} +#' or an explicit QtlSumStats trait-position and carried as provenance onto +#' \code{QtlFineMappingResult} and \code{TwasWeights}. +#' @param x The object. +#' @param ... Reserved for future use. +#' @return A \code{GRanges} with one range per row of \code{x}, or an empty +#' \code{GRanges} when the collection carries no trait-position provenance. +#' @export +setGeneric("getTraitPosition", + function(x, ...) standardGeneric("getTraitPosition")) + #' @title Get Residualized Genotypes #' @description Residualize the genotype matrix against the per-context #' phenotype covariates and the genotype covariates, optionally diff --git a/R/AnnotationMatrix.R b/R/AnnotationMatrix.R index 015115d3..5112d726 100644 --- a/R/AnnotationMatrix.R +++ b/R/AnnotationMatrix.R @@ -89,3 +89,75 @@ setMethod("getSnpRanges", "AnnotationMatrix", function(x) x@snpRanges) #' @rdname getGenome #' @export setMethod("getGenome", "AnnotationMatrix", function(x, ...) x@genome) + +# ============================================================================= +# Constructor +# ============================================================================= + +#' @title Create an AnnotationMatrix Object +#' @description Construct an \code{AnnotationMatrix} from a matrix and metadata. +#' @param annotations A numeric matrix or sparse matrix (SNPs x annotations). +#' @param snpRanges A \code{GRanges} object with SNP positions. +#' @param annotationMeta A data.frame with columns: name, tier, type. +#' @param genome Character, genome build. +#' @return An \code{AnnotationMatrix} object. +#' @export +AnnotationMatrix <- function(annotations, snpRanges, annotationMeta, + genome = "hg19") { + # Validate annotationMeta + if (!is.data.frame(annotationMeta)) + stop("annotationMeta must be a data.frame") + + requiredCols <- c("name", "tier", "type") + if (!all(requiredCols %in% colnames(annotationMeta))) + stop("annotationMeta must have columns: name, tier, type") + + # Set column names on matrix + if (is.null(colnames(annotations))) + colnames(annotations) <- annotationMeta$name + + new("AnnotationMatrix", + snpRanges = snpRanges, + annotations = annotations, + annotationMeta = annotationMeta, + genome = genome + ) +} + +# ============================================================================= +# Tier accessors +# ============================================================================= + +#' @title Get Baseline Annotations +#' @description Extract only baseline-tier annotations from an +#' \code{AnnotationMatrix}. +#' @param annot An \code{AnnotationMatrix} object. +#' @return An \code{AnnotationMatrix} with only baseline annotations. +#' @export +getBaseline <- function(annot) { + meta <- getAnnotationMeta(annot) + idx <- meta$tier == "baseline" + AnnotationMatrix( + annotations = getAnnotations(annot)[, idx, drop = FALSE], + snpRanges = getSnpRanges(annot), + annotationMeta = meta[idx, , drop = FALSE], + genome = getGenome(annot) + ) +} + +#' @title Get Candidate Annotations +#' @description Extract only candidate-tier annotations from an +#' \code{AnnotationMatrix}. +#' @param annot An \code{AnnotationMatrix} object. +#' @return An \code{AnnotationMatrix} with only candidate annotations. +#' @export +getCandidates <- function(annot) { + meta <- getAnnotationMeta(annot) + idx <- meta$tier == "candidate" + AnnotationMatrix( + annotations = getAnnotations(annot)[, idx, drop = FALSE], + snpRanges = getSnpRanges(annot), + annotationMeta = meta[idx, , drop = FALSE], + genome = getGenome(annot) + ) +} diff --git a/R/FineMappingEntry.R b/R/FineMappingEntry.R index 1d41d89d..92d2d4d5 100644 --- a/R/FineMappingEntry.R +++ b/R/FineMappingEntry.R @@ -165,7 +165,7 @@ setMethod("getCvResult", "FineMappingEntry", #' @export setMethod("getTopLoci", "FineMappingEntry", function(x, type = c("data.frame", "GRanges"), - signalCutoff = 0.025, ...) { + signalCutoff = 0.025, minPurity = NULL, ...) { type <- match.arg(type) tl <- x@topLoci if (nrow(tl) == 0L) { @@ -176,6 +176,22 @@ setMethod("getTopLoci", "FineMappingEntry", } else { !is.na(tl$pip) & tl$pip > signalCutoff } + # Independent purity filter, orthogonal to the pip `signalCutoff`: drop + # variants that belong to a below-`minPurity` primary (highest-coverage) + # credible set. Variants not in a CS are unaffected. + if (!is.null(minPurity)) { + purCols <- grep("^cs_[0-9.]+_purity$", names(tl), value = TRUE) + if (length(purCols) > 0L) { + covs <- suppressWarnings(as.numeric(sub("_purity$", "", + sub("^cs_", "", purCols)))) + primaryPur <- purCols[which.max(covs)] + csCol <- sub("_purity$", "", primaryPur) + inCs <- if (csCol %in% names(tl)) !grepl("_0$", tl[[csCol]]) else + rep(FALSE, nrow(tl)) + pur <- as.numeric(tl[[primaryPur]]) + keep <- keep & !(inCs & !is.na(pur) & pur < minPurity) + } + } out <- .projectPosteriorView(tl[keep, , drop = FALSE]) } if (type == "data.frame") return(out) @@ -213,13 +229,25 @@ setMethod("getPip", "FineMappingEntry", function(x, ...) { #' @rdname getCs #' @export setMethod("getCs", "FineMappingEntry", - function(x, coverage = 0.95, ...) { + function(x, coverage = 0.95, minPurity = NULL, ...) { tl <- x@topLoci if (nrow(tl) == 0L) return(.projectPosteriorView(tl)) csCol <- grep(paste0("^cs_", coverage * 100, "$"), names(tl), value = TRUE) if (length(csCol) == 0L) return(.projectPosteriorView(tl[FALSE, , drop = FALSE])) keep <- !is.na(tl[[csCol[1L]]]) & nzchar(tl[[csCol[1L]]]) & !grepl("_0$", tl[[csCol[1L]]]) + # Independent purity filter (min.abs.corr), orthogonal to `coverage`: drop + # CS members whose credible set at THIS coverage is below `minPurity`. + if (!is.null(minPurity)) { + purCol <- paste0(csCol[1L], "_purity") + if (purCol %in% names(tl)) { + pur <- as.numeric(tl[[purCol]]) + keep <- keep & !is.na(pur) & pur >= minPurity + } else { + warning("getCs: no purity column '", purCol, "' for coverage ", + coverage, "; minPurity filter skipped.") + } + } .projectPosteriorView(tl[keep, , drop = FALSE]) }) @@ -338,7 +366,7 @@ setMethod("show", "FineMappingEntry", function(object) { variant_id = character(0), chrom = character(0), pos = integer(0), A1 = character(0), A2 = character(0), N = numeric(0), af = numeric(0), - beta = numeric(0), se = numeric(0), pip = numeric(0), + beta = numeric(0), se = numeric(0), pip = numeric(0), logBF = numeric(0), stringsAsFactors = FALSE)) } out <- data.frame( @@ -352,11 +380,19 @@ setMethod("show", "FineMappingEntry", function(object) { beta = .tlCol(tl, "posterior_mean", "numeric"), se = .tlCol(tl, "posterior_sd", "numeric"), pip = .tlCol(tl, "pip", "numeric"), + logBF = .tlCol(tl, "logBF", "numeric"), stringsAsFactors = FALSE) - # Pass through CS columns (cs_95, cs_70, cs_50, cs_95_purity) and - # pipeline stamps (method, gene, event, grange_*) when present. + # Pass through the dynamic CS columns (cs_ membership / cs__purity for + # any coverage the pipeline produced), the per-condition posterior quantities + # for multi-condition fits (conditional_effect, lfsr; long + numeric, never + # collapsed), and pipeline stamps (method, gene, event, grange_*) when present. + csCols <- grep("^cs_[0-9.]+(_purity)?$", colnames(tl), value = TRUE) + # Per-CS variant-level fullFit columns: within_cs_pip (default scalar) +, when + # built with fullFit=TRUE, the wide within_cs_pip_ / cs_logbf_ / + # cs_effect_ / cs_effect_var_ sets. + fullFitCols <- grep("^(within_cs_pip|cs_logbf_|cs_effect_)", colnames(tl), value = TRUE) extraCols <- intersect( - c("cs_95", "cs_70", "cs_50", "cs_95_purity", + c(csCols, fullFitCols, "conditional_effect", "lfsr", "method", "gene", "event", "grange_start", "grange_end"), colnames(tl)) for (cc in extraCols) out[[cc]] <- tl[[cc]] diff --git a/R/GwasFineMappingResult.R b/R/GwasFineMappingResult.R index 99bc5fdb..a8b72649 100644 --- a/R/GwasFineMappingResult.R +++ b/R/GwasFineMappingResult.R @@ -37,6 +37,7 @@ setClass("GwasFineMappingResult", errors <- c(errors, "every element of the `entry` column must be a FineMappingEntry") errors <- c(errors, .validateRegionColumn(object)) + errors <- c(errors, .validateTraitPosColumn(object)) # Extract key columns directly rather than via `object[, keyCols]`: # column-subsetting preserves the GwasFineMappingResult class while # dropping the required `entry` column, and older S4Vectors revalidates @@ -115,6 +116,7 @@ setClass("GwasFineMappingResult", GwasFineMappingResult <- function(study, method, entry, region_id = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL) { n <- length(study) if (length(method) != n || length(entry) != n) { @@ -134,6 +136,7 @@ GwasFineMappingResult <- function(study, method, entry, ) if (is.null(region)) region <- .regionFromIds(region_id) cols <- .appendRegionCol(cols, region, n) + cols <- .appendTraitPosCol(cols, traitPos, n) df <- do.call(S4Vectors::DataFrame, c(cols, list(check.names = FALSE))) obj <- new("GwasFineMappingResult", df, ldSketch = ldSketch) diff --git a/R/QtlDataset.R b/R/QtlDataset.R index 27870385..36f50fbf 100644 --- a/R/QtlDataset.R +++ b/R/QtlDataset.R @@ -258,6 +258,46 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) region } +# Per-trait genomic position: each trait's OWN rowRanges span across contexts +# (union min-start to max-end), WITHOUT the cisWindow expansion. One range per +# traitId (a 0-width chrUn sentinel for a trait absent from every context), for +# threading trait-position provenance onto QtlFineMappingResult / TwasWeights. +# @noRd +.qtlTraitPos <- function(x, traitIds) { + # Extract chrom/start/end as plain vectors per trait (union span across + # contexts), then build ONE fresh GRanges at the end. Combining per-context + # GRanges with do.call(c, .) can trip S4 seqinfo reconciliation in some + # GenomeInfoDb builds, so we avoid it entirely. + n <- length(traitIds) + chrs <- rep("chrUn", n); starts <- rep(1L, n); ends <- rep(1L, n) + for (i in seq_len(n)) { + tid <- traitIds[[i]]; st <- Inf; en <- -Inf; ch <- NA_character_ + for (se in x@phenotypes) { + h <- match(tid, rownames(se)); h <- h[!is.na(h)] + if (length(h) == 0L) next + rr <- SummarizedExperiment::rowRanges(se)[h] + ch <- as.character(GenomicRanges::seqnames(rr))[1L] + st <- min(st, GenomicRanges::start(rr)) + en <- max(en, GenomicRanges::end(rr)) + } + if (!is.na(ch)) { + chrs[i] <- ch; starts[i] <- as.integer(st); ends[i] <- as.integer(en) + } + } + gr <- GenomicRanges::GRanges( + chrs, IRanges::IRanges(start = starts, end = pmax(ends, starts))) + names(gr) <- traitIds + gr +} + +#' @rdname getTraitPosition +#' @export +setMethod("getTraitPosition", "QtlDataset", function(x, traitId = NULL, ...) { + tids <- if (is.null(traitId)) unique(unlist(lapply(x@phenotypes, rownames))) + else as.character(traitId) + .qtlTraitPos(x, tids) +}) + # Internal: map a GRanges region (one or more ranges) into 1-based snpIdx into # handle@snpInfo. Indices are unioned across ranges in range order (first # occurrence wins), so overlapping ranges contribute each variant once. @@ -443,8 +483,12 @@ setMethod("getScaleResiduals", "QtlDataset", function(x) x@scaleResiduals) mafVec <- mafVec[keepVarMask] afVec <- afVec[keepVarMask] } else { + # nocov start (unreachable: every zero-variant path returns early above, so + # ncol(dosage) is always >= 1 here; kept so mafVec/afVec stay defined if a + # future refactor removes one of those guards) mafVec <- numeric(0) afVec <- numeric(0) + # nocov end } # Mean-impute remaining missing dosage cells so downstream linear diff --git a/R/QtlFineMappingResult.R b/R/QtlFineMappingResult.R index c8d2ec13..99ea09cb 100644 --- a/R/QtlFineMappingResult.R +++ b/R/QtlFineMappingResult.R @@ -34,6 +34,7 @@ setClass("QtlFineMappingResult", errors <- c(errors, "every element of the `entry` column must be a FineMappingEntry") errors <- c(errors, .validateRegionColumn(object)) + errors <- c(errors, .validateTraitPosColumn(object)) jointCols <- intersect( c("jointStudies", "jointContexts", "jointTraits"), names(object)) for (jc in jointCols) { @@ -110,6 +111,7 @@ QtlFineMappingResult <- function(study, context, trait, method, entry, jointContexts = NULL, jointTraits = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL) { n <- length(study) if (length(context) != n || length(trait) != n || length(method) != n || @@ -134,6 +136,7 @@ QtlFineMappingResult <- function(study, context, trait, method, entry, cols[[pair[[2L]]]] <- as.character(val) } cols <- .appendRegionCol(cols, region, n) + cols <- .appendTraitPosCol(cols, traitPos, n) df <- do.call(S4Vectors::DataFrame, c(cols, list(check.names = FALSE))) obj <- new("QtlFineMappingResult", df, ldSketch = ldSketch) diff --git a/R/colocboostPipeline.R b/R/colocboostPipeline.R index 24835073..30f70a6e 100644 --- a/R/colocboostPipeline.R +++ b/R/colocboostPipeline.R @@ -1,3 +1,4 @@ +#' @include qtlSumStats.R #' @title ColocBoost multi-trait colocalization pipeline (S4) #' @description Protocol-level multi-trait colocalization analysis using #' \pkg{colocboost}. Dispatches on the QTL input type: diff --git a/R/credibleSetSummary.R b/R/credibleSetSummary.R new file mode 100644 index 00000000..54c169f0 --- /dev/null +++ b/R/credibleSetSummary.R @@ -0,0 +1,116 @@ +#' @include AllGenerics.R AllClasses.R FineMappingEntry.R tupleSelectors.R +NULL + +.emptyCsSummary <- function() { + data.frame(cs = character(), effect_id = character(), coverage = numeric(), + n_variants = integer(), purity_min = numeric(), + purity_mean = numeric(), V = numeric(), cs_log10bf = numeric(), + cs_log_bf = numeric(), cs_pip = numeric(), cs_mean_effect = numeric(), + lead_variant = character(), lead_pip = numeric(), + stringsAsFactors = FALSE) +} + +# The per-effect single-effect log Bayes factor: log of the average (over the +# flat prior) of the effect's per-variant Bayes factors, i.e. +# logSumExp(lbf_variable[L, ]) - log(p). This is the principled per-CS evidence, +# unlike the max-member per-variant logBF. NA when the fit carries no lbf matrix. +.csEffectLogBf <- function(fit, Lidx) { + lbf <- fit$lbf_variable + if (is.null(lbf) || !is.matrix(lbf) || is.na(Lidx) || Lidx > nrow(lbf)) + return(NA_real_) + lv <- as.numeric(lbf[Lidx, ]); lv <- lv[is.finite(lv)] + if (length(lv) == 0L) return(NA_real_) + mx <- max(lv) + mx + log(sum(exp(lv - mx))) - log(length(lv)) +} + +# One row per credible set at `coverage`, summarising size, purity (min from the +# canonical cs__purity column, mean from the fit's sets$purity when present), +# the per-effect prior variance V, the CS log Bayes factor (max member logBF), +# and the lead (highest-PIP) variant. Sourced primarily from the entry's topLoci +# so it stays consistent with getCs / getTopLoci; V / mean-purity come from the +# stored fit. The credible-set index in the `cs` label doubles as the effect (L) +# index for susie-family fits (unfiltered CS are ordered by effect). +# @noRd +.csSummaryFit <- function(tl, fit, coverage) { + csCol <- paste0("cs_", coverage * 100) + purCol <- paste0(csCol, "_purity") + if (is.null(tl) || nrow(tl) == 0L || !(csCol %in% names(tl))) + return(.emptyCsSummary()) + labels <- unique(tl[[csCol]][!is.na(tl[[csCol]]) & nzchar(tl[[csCol]]) & + !grepl("_0$", tl[[csCol]])]) + if (length(labels) == 0L) return(.emptyCsSummary()) + + Vvec <- if (!is.null(fit$V)) as.numeric(fit$V) else NULL + meanPur <- NULL + sp <- fit$sets$purity + if (!is.null(sp)) { + mc <- intersect(c("meanAbsCorr", "mean.abs.corr"), names(sp)) + if (length(mc) > 0L) + meanPur <- stats::setNames(as.numeric(sp[[mc[1L]]]), rownames(sp)) + } + + rows <- lapply(labels, function(lab) { + m <- tl[tl[[csCol]] == lab, , drop = FALSE] + Lidx <- suppressWarnings(as.integer(sub("^.*_", "", lab))) + Lname <- if (!is.na(Lidx)) paste0("L", Lidx) else NA_character_ + lead <- which.max(m$pip) + data.frame( + cs = lab, effect_id = Lname, coverage = coverage, n_variants = nrow(m), + purity_min = if (purCol %in% names(m)) as.numeric(m[[purCol]][1]) else NA_real_, + purity_mean = if (!is.null(meanPur) && !is.na(Lname) && Lname %in% names(meanPur)) + as.numeric(meanPur[[Lname]]) else NA_real_, + V = if (!is.null(Vvec) && !is.na(Lidx) && Lidx <= length(Vvec)) + Vvec[Lidx] else NA_real_, + # cs_log10bf: the strongest MEMBER variant's logBF (max over the CS). + cs_log10bf = if ("logBF" %in% names(m)) + suppressWarnings(max(m$logBF, na.rm = TRUE)) else NA_real_, + # cs_log_bf: the true per-EFFECT single-effect log Bayes factor. + cs_log_bf = .csEffectLogBf(fit, Lidx), + # cs_pip: total posterior inclusion mass captured by the CS (summed member PIP). + cs_pip = suppressWarnings(sum(as.numeric(m$pip), na.rm = TRUE)), + # cs_mean_effect: mean posterior conditional effect over the CS (NA when the + # entry has no conditional_effect column, e.g. univariate susie). + cs_mean_effect = if ("conditional_effect" %in% names(m)) + suppressWarnings(mean(as.numeric(m$conditional_effect), na.rm = TRUE)) else NA_real_, + lead_variant = as.character(m$variant_id[lead]), + lead_pip = as.numeric(m$pip[lead]), + stringsAsFactors = FALSE) + }) + out <- do.call(rbind, rows) + out$cs_log10bf[!is.finite(out$cs_log10bf)] <- NA_real_ + out +} + +#' Per-credible-set summary of a fine-mapping result +#' +#' One row per credible set (at a given coverage) with its size, purity, prior +#' variance, log Bayes factor, and lead variant — the per-CS complement to the +#' per-variant \code{\link{getCs}}. Replaces the legacy per-effect `effect.tsv`. +#' +#' @param x A \code{FineMappingEntry} or \code{FineMappingResultBase}. +#' @param coverage Credible-set coverage to summarise. Default 0.95. +#' @param ... Ignored. +#' @return A \code{data.frame}: \code{cs, effect_id, coverage, n_variants, +#' purity_min, purity_mean, V, cs_log10bf} (strongest member logBF), +#' \code{cs_log_bf} (true per-effect single-effect log Bayes factor), +#' \code{cs_pip} (summed member PIP = inclusion mass captured), \code{cs_mean_effect} +#' (mean posterior conditional effect), \code{lead_variant, lead_pip} (the +#' collection method also carries the entry identity columns). +#' @seealso \code{\link{getCs}}, \code{\link{getTopLoci}} +#' @export +setGeneric("getCredibleSetSummary", + function(x, ...) standardGeneric("getCredibleSetSummary")) + +#' @rdname getCredibleSetSummary +#' @export +setMethod("getCredibleSetSummary", "FineMappingEntry", + function(x, coverage = 0.95, ...) + .csSummaryFit(x@topLoci, getSusieFit(x), coverage)) + +#' @rdname getCredibleSetSummary +#' @export +setMethod("getCredibleSetSummary", "FineMappingResultBase", + function(x, coverage = 0.95, ...) + .fmrAggregateView(x, + perEntry = function(e) getCredibleSetSummary(e, coverage = coverage))) diff --git a/R/ctwasPipeline.R b/R/ctwasPipeline.R index 1d846bda..e411bf52 100644 --- a/R/ctwasPipeline.R +++ b/R/ctwasPipeline.R @@ -295,6 +295,9 @@ assembleCtwasInputs <- function(gwasSumStats, twasWeights, gss <- gwasSumStats[[rid]] tw <- twasWeights[[rid]] # may be NULL for SNP-only blocks gwasLd <- getLdSketch(gss) + if (is.null(gwasLd)) + stop("ctwasPipeline: GwasSumStats for region '", rid, "' carries no ", + "ldSketch (ldSketch = NULL); cTWAS requires an LD reference.") if (!is.null(tw)) .ctwasRequireMatchingLdSketches(getLdSketch(tw), gwasLd) @@ -381,7 +384,7 @@ assembleCtwasInputs <- function(gwasSumStats, twasWeights, #' @param fallbackToPrefit Logical (length 1). When \code{TRUE} (default #' \code{FALSE}), if \code{ctwas::est_param}'s accurate EM fails for ANY #' reason on a degenerate input, re-run only the prefit step via -#' \code{ctwas:::fit_EM} and return those (typically finite) priors as the +#' ctwas's internal \code{fit_EM} and return those (typically finite) priors as the #' param. The accurate-EM failure mode is version-dependent (ctwas <= 0.4.x: #' \code{"contains NAs"}; ctwas >= 0.6.0: \code{"No regions selected!"} or a #' NaN-loglik \code{"missing value where TRUE/FALSE needed"}), so the catch is @@ -583,6 +586,9 @@ finemapCtwasRegions <- function(screenResult, snpinfo_loader_fun = screenResult$snpinfo_loader_fun, ncore = as.integer(ncore)), extra = list(...)) } + # Repair cTWAS's molecular_id mislabel (first-"|" split of our composite id). + fmRes$finemap_res <- .ctwasFixMolecularId(fmRes$finemap_res) + fmRes$susie_alpha_res <- .ctwasFixMolecularId(fmRes$susie_alpha_res) list( z_gene = screenResult$z_gene, param = screenResult$param, @@ -732,7 +738,7 @@ mergeCtwasBoundaryRegions <- function(finemapResult, # param list shaped like ctwas::est_param normally produces. Used as # the fallback path when est_param's accurate EM diverges to NaN on # toy / underpowered data (matches the legacy ctwas_2 workaround). -# Calls ctwas's internal `fit_EM` (via ::: getFromNamespace) with +# Calls ctwas's internal `fit_EM` (via getFromNamespace) with # niter = niter_prefit, then applies the same thin-adjustment to the # SNP group_prior that est_param applies. p_single_effect is left as # NA since the accurate EM never ran. @@ -997,6 +1003,21 @@ mergeCtwasBoundaryRegions <- function(finemapResult, stringsAsFactors = FALSE) } +# cTWAS's finemap_regions derives `molecular_id` by splitting the gene id on the +# FIRST "|", which mislabels our composite `region|study|context|trait|method` +# id (it takes the region as the molecular_id). Restore the true trait for gene +# rows; SNP-background rows (variant ids, no "|") are left untouched. +# @noRd +.ctwasFixMolecularId <- function(df) { + if (is.null(df) || !is.data.frame(df) || nrow(df) == 0L || + !all(c("id", "molecular_id") %in% names(df))) return(df) + isGene <- lengths(strsplit(as.character(df$id), "|", fixed = TRUE)) >= 5L + if (any(isGene)) + df$molecular_id[isGene] <- + .ctwasParseGeneIds(as.character(df$id)[isGene])$trait + df +} + # Enforce the multi-context joint-model invariant: every context in a run must # carry the SAME set of genes (traits). A cTWAS joint fit couples the contexts # through shared group priors; contexts with disjoint gene sets make the joint diff --git a/R/deprecated.R b/R/deprecated.R index 148b250f..c32c7c5e 100644 --- a/R/deprecated.R +++ b/R/deprecated.R @@ -16,6 +16,9 @@ # Group ordering: by deprecation target (which active API replaces them). # ============================================================================= +# nocov start +# This entire file holds deprecated stubs scheduled for removal; it is excluded +# from coverage so the retired surface does not dilute the active-code metric. # ----------------------------------------------------------------------------- # Allele harmonization (matchRefPanel / alleleQc → summaryStatsQc) @@ -696,3 +699,4 @@ loadMultitraitRSumstat <- function(...) { "for harmonization, then pass them to mashPipeline().")) invisible(NULL) } +# nocov end diff --git a/R/exampleData.R b/R/exampleData.R index bd841c9f..026a2760 100644 --- a/R/exampleData.R +++ b/R/exampleData.R @@ -124,7 +124,7 @@ NULL #' names(qtl_finemapping_example[["region_1"]][["context_1"]]) #' NULL -#' @name multitraite_data +#' @name multitrait_data #' #' @title Simulated Multi-condition Data for TWAS analysis #' @@ -137,7 +137,7 @@ NULL #' TWAS analysis. Genotype matrix is centered and scaled, expression matrix is #' normalized. #' -#' @format \code{multitraite_data} is a list with the following elements: +#' @format \code{multitrait_data} is a list with the following elements: #' #' \describe{ #' @@ -177,7 +177,7 @@ NULL #' PLoS Genetics 19(7): e1010539. https://doi.org/10.1371/journal.pgen.1010539 #' #' @examples -#' data(multitraite_data) +#' data(multitrait_data) #' NULL diff --git a/R/fineMappingPipeline.R b/R/fineMappingPipeline.R index e03e0ccc..d4a050da 100644 --- a/R/fineMappingPipeline.R +++ b/R/fineMappingPipeline.R @@ -1,3 +1,4 @@ +#' @include qtlSumStats.R gwasSumStats.R #' @title Fine-Mapping Pipeline #' @description S4-dispatched per-region fine-mapping entry point that #' replaces the deprecated \code{univariateAnalysisPipeline}, @@ -247,6 +248,23 @@ #' (\code{lbf_variable}, \code{mu}, \code{mu2}, \code{V}). The #' per-variant \code{topLoci} table is always fully populated #' regardless of \code{trim}. +#' @param fullFit Logical (length 1, default \code{FALSE}). Master switch for +#' per-credible-set variant-level export in \code{topLoci}. When \code{FALSE}, +#' only the always-on \code{within_cs_pip} scalar column is added (each +#' variant's \code{alpha} in its assigned primary-coverage credible set; NA +#' when not in a set). When \code{TRUE}, wide per-CS columns are added, one +#' set of columns per credible set (labelled \code{cs}). +#' @param fullFitAlphaOnly Logical (length 1, default \code{TRUE}). No-op when +#' \code{fullFit=FALSE}. When \code{TRUE}, only \code{alpha} is widened +#' (\code{within_cs_pip_cs}). When \code{FALSE}, all four per-effect +#' matrices are widened: \code{within_cs_pip_cs} (alpha), +#' \code{cs_logbf_cs} (lbf_variable), \code{cs_effect_cs} (mu, unscaled) +#' and \code{cs_effect_var_cs} (posterior variance, unscaled). +#' @param includeAllCs Logical (length 1, default \code{FALSE}). No-op when +#' \code{fullFit=FALSE}. When \code{FALSE}, only effects that produced a +#' passing (purity/coverage-filtered) credible set are widened. When +#' \code{TRUE}, every effect \code{L} is widened (including filtered-out ones, +#' labelled \code{L} instead of \code{cs}). #' @param ... Reserved for future per-method arguments. #' #' @return A \code{\link{FineMappingResult}} collection keyed by @@ -534,6 +552,8 @@ setGeneric("fineMappingPipeline", jointStudies = NULL, jointContexts = NULL, jointTraits = NULL, + region = NULL, + traitPos = NULL, ldSketch = NULL) { if (length(entries) == 0L) { stop("fineMappingPipeline: no (study, context, trait, method) tuples ", @@ -548,6 +568,8 @@ setGeneric("fineMappingPipeline", jointStudies = jointStudies, jointContexts = jointContexts, jointTraits = jointTraits, + region = region, + traitPos = traitPos, ldSketch = ldSketch) } @@ -693,7 +715,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, region = NULL, trim = NULL, - medianAbsCorr = NULL, conditionIdx = NULL) { + medianAbsCorr = NULL, conditionIdx = NULL, + fullFit = NULL, fullFitAlphaOnly = NULL, + includeAllCs = NULL) { # Inherit `trim` from the calling method's frame if not passed in # explicitly. The 10 internal call sites don't currently forward it # (they predate the trim knob) so we look it up from the caller. This @@ -709,6 +733,15 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { medianAbsCorr <- tryCatch(get("medianAbsCorr", envir = parent.frame()), error = function(e) NULL) } + # fullFit / fullFitAlphaOnly / includeAllCs are threaded explicitly by every + # internal caller: the univariate/RSS block fitters (.fmFitXBlock / + # .fmFitRssBlock) forward the setMethod params, and the joint engine passes + # them from the pipeline config (its fitJointGroup frame does not lexically + # see the method's params). NULL here is only a defensive default for a bare + # direct call, so the safe/minimal behavior applies. + if (is.null(fullFit)) fullFit <- FALSE + if (is.null(fullFitAlphaOnly)) fullFitAlphaOnly <- TRUE + if (is.null(includeAllCs)) includeAllCs <- FALSE fits <- setNames(list(fit), method) post <- postprocessFinemappingFits( fits = fits, dataX = dataX, dataY = dataY, @@ -717,7 +750,9 @@ combineFineMappingResults <- function(..., ldSketch = NULL) { signalCutoff = signalCutoff, minAbsCorr = minAbsCorr, medianAbsCorr = medianAbsCorr, region = region, - csInput = csInput, conditionIdx = conditionIdx, trim = isTRUE(trim)) + csInput = csInput, conditionIdx = conditionIdx, trim = isTRUE(trim), + fullFit = isTRUE(fullFit), fullFitAlphaOnly = isTRUE(fullFitAlphaOnly), + includeAllCs = isTRUE(includeAllCs)) out <- formatFinemappingOutput(post, primaryMethod = method) # `formatFinemappingOutput` returns a list with $finemappingEntry as a # bare FineMappingEntry per the helper's contract. @@ -1243,6 +1278,9 @@ setMethod("fineMappingPipeline", "QtlDataset", naAction = c("drop", "impute"), verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, phenotypeCovariatesToResidualize = NULL, genotypeCovariatesToResidualize = NULL, residualizePhenotypeCovariates = TRUE, @@ -1285,7 +1323,9 @@ setMethod("fineMappingPipeline", "QtlDataset", dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, pipCutoffToSkip = pipCutoffToSkip, - fineMappingResult = fineMappingResult) + fineMappingResult = fineMappingResult, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) tokens <- setdiff(tokens, c("mvsusie", "fsusie")) methodArgs <- methodArgs[tokens] if (length(tokens) == 0L) { @@ -1425,7 +1465,8 @@ setMethod("fineMappingPipeline", "QtlDataset", secondaryCoverage, signalCutoff, minAbsCorr, methodArgs, verbose, ctx, tid, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, - af = afVec) + af = afVec, fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) }) for (tk in toRun) { @@ -1476,7 +1517,8 @@ setMethod("fineMappingPipeline", "QtlDataset", secondaryCoverage, signalCutoff, minAbsCorr, methodArgs, verbose, ctx, pcName, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, - af = afVec) + af = afVec, fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) }) ents <- lapply(blockEntries, function(be) be[["susie"]]) if (any(vapply(ents, is.null, logical(1)))) next @@ -1505,7 +1547,9 @@ setMethod("fineMappingPipeline", "QtlDataset", dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, pipCutoffToSkip = pipCutoffToSkip, - fineMappingResult = fineMappingResult) + fineMappingResult = fineMappingResult, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) jointResult <- if (is.null(jointResult)) autoJoint else if (is.null(autoJoint)) jointResult else .rbindFineMappingResult(jointResult, autoJoint, @@ -1514,6 +1558,13 @@ setMethod("fineMappingPipeline", "QtlDataset", perTupleResult <- if (length(rowEntries) > 0L) .fmBuildQtlResult(rowStudy, rowContext, rowTrait, rowMethod, rowEntries, + region = tryCatch( + .anchorVector(data, rowContext, rowTrait, "region", + cisWindow), + error = function(e) NULL), + traitPos = tryCatch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(e) NULL), ldSketch = NULL) else NULL @@ -1560,6 +1611,9 @@ setMethod("fineMappingPipeline", "MultiStudyQtlDataset", naAction = c("drop", "impute"), verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, phenotypeCovariatesToResidualize = NULL, genotypeCovariatesToResidualize = NULL, residualizePhenotypeCovariates = TRUE, @@ -1659,6 +1713,9 @@ setMethod("fineMappingPipeline", "QtlSumStats", dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, ...) { .fmAssertQcd(data) parsedJointSpec <- parseJointSpecification(jointSpecification, data) @@ -1676,7 +1733,9 @@ setMethod("fineMappingPipeline", "QtlSumStats", methodArgs = methodArgs, twasWeights = twasWeights, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - fineMappingResult = fineMappingResult) + fineMappingResult = fineMappingResult, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) tokens <- setdiff(tokens, c("mvsusie", "fsusie")) methodArgs <- methodArgs[tokens] if (length(tokens) == 0L) { @@ -1766,7 +1825,8 @@ setMethod("fineMappingPipeline", "QtlSumStats", z, ldMat, n, toRun, addSusieInf, coverage, secondaryCoverage, signalCutoff, minAbsCorr, methodArgs, verbose, label = sprintf("(study='%s', context='%s', trait='%s')", st, ctx, tr), - af = afByVar) + af = afByVar, fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) # The method column carries the bare token, independent of the # postprocess class. for (tk in names(ents)) pushRow(st, ctx, tr, tk, ents[[tk]]) @@ -1788,7 +1848,9 @@ setMethod("fineMappingPipeline", "QtlSumStats", methodArgs = methodArgs, twasWeights = twasWeights, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - fineMappingResult = fineMappingResult) + fineMappingResult = fineMappingResult, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) jointResult <- if (is.null(jointResult)) autoJoint else if (is.null(autoJoint)) jointResult else .rbindFineMappingResult(jointResult, autoJoint, @@ -1797,6 +1859,15 @@ setMethod("fineMappingPipeline", "QtlSumStats", perTupleResult <- if (length(rowEntries) > 0L) .fmBuildQtlResult(rowStudy, rowContext, rowTrait, rowMethod, rowEntries, + # QtlSumStats: region = the entry's variant span (no + # cis-window); traitPos = the supplied column or NULL + # (omitted -> getTraitPosition() returns NA). + region = tryCatch( + .anchorVector(data, rowContext, rowTrait, "region"), + error = function(e) NULL), + traitPos = tryCatch( + .anchorVector(data, rowContext, rowTrait, "traitPos"), + error = function(e) NULL), ldSketch = ldSketch) else NULL if (is.null(jointResult)) { @@ -1829,6 +1900,9 @@ setMethod("fineMappingPipeline", "GwasSumStats", fineMappingResult = NULL, verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, ...) { .fmAssertQcd(data) norm <- .fmNormalizeMethods(methods, L = L, Lgreedy = Lgreedy) @@ -1902,7 +1976,8 @@ setMethod("fineMappingPipeline", "GwasSumStats", z, ldMat, n, toRun, addSusieInf, coverage, secondaryCoverage, signalCutoff, minAbsCorr, methodArgs, verbose, label = sprintf("GWAS (study='%s', region='%s')", st, region_id), - af = afByVar) + af = afByVar, fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) for (tk in names(ents)) pushRow(st, tk, region_id, ents[[tk]]) } diff --git a/R/fineMappingWrappers.R b/R/fineMappingWrappers.R index 7beabfa8..39fdc7bd 100644 --- a/R/fineMappingWrappers.R +++ b/R/fineMappingWrappers.R @@ -240,7 +240,7 @@ fitSusieInfThenSusieRss <- function(z, R, n, args = list(), #' @return A list with \code{finemappingResults} (per-method post-processed #' objects, each carrying a trimmed fit and method-specific intermediates) #' and a single unified \code{top_loci} table in the fixed 22-column shape -#' (see \code{\link{buildTopLoci}}). Per-method contributions are +#' (see the internal \code{buildTopLoci}). Per-method contributions are #' row-bound into \code{top_loci} by an outer method for-loop. #' @export postprocessFinemappingFits <- function(fits, dataX, dataY = NULL, @@ -255,7 +255,10 @@ postprocessFinemappingFits <- function(fits, dataX, dataY = NULL, medianAbsCorr = NULL, csInput = NULL, conditionIdx = NULL, - trim = TRUE) { + trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { fits <- fits[!vapply(fits, is.null, logical(1))] if (length(fits) == 0) stop("At least one fine-mapping fit must be supplied.") if (is.null(names(fits)) || any(names(fits) == "")) { @@ -277,7 +280,9 @@ postprocessFinemappingFits <- function(fits, dataX, dataY = NULL, medianAbsCorr = medianAbsCorr, csInput = csInput, conditionIdx = conditionIdx, - trim = trim + trim = trim, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) }) names(posts) <- names(fits) @@ -347,6 +352,9 @@ postprocessFinemappingFit.susiF <- function(fit, method = "fsusie", csInput = NU minAbsCorr = 0.8, medianAbsCorr = NULL, conditionIdx = NULL, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, csInput = c("X", "Xcorr", "fsusie")) { csInput <- match.arg(csInput) variantNames <- extractVariantNames(fit) @@ -365,7 +373,9 @@ postprocessFinemappingFit.susiF <- function(fit, method = "fsusie", csInput = NU fit, csTables, variantNames = variantNames, sumstats = sumstats, af = af, method = method, signalCutoff = 0, dataX = dataX, dataY = dataY, otherQuantities = otherQuantities, - region = region, conditionIdx = conditionIdx + region = region, conditionIdx = conditionIdx, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs ) # When `trim = TRUE` we store a minimal subset of the fit on the @@ -491,10 +501,22 @@ computeCsTable <- function(fit, dataX, coverage, csInput = c("X", "Xcorr", "fsus } tmp <- fit tmp$sets <- sets - csCorr <- if (requireNamespace("fsusieR", quietly = TRUE)) { - tryCatch(fsusieR::cal_cor_cs(tmp, dataX), error = function(e) NULL) - } else { - NULL + csCorr <- NULL + if (requireNamespace("fsusieR", quietly = TRUE)) { + # Credible-set PURITY is the min |correlation| WITHIN each CS's variants, + # which fsusieR computes with cal_purity(). (cal_cor_cs() computes the + # BETWEEN-CS correlation and returns the whole fit object, so it is the + # wrong quantity for purity.) Stamp it as sets$purity$min.abs.corr so the + # canonical .csPurityVec() reads it directly (the susieR path shape). + purity <- tryCatch( + as.numeric(unlist(fsusieR::cal_purity(sets$cs, dataX))), + error = function(e) NULL) + if (!is.null(purity) && length(purity) == length(sets$cs)) { + sets$purity <- data.frame(min.abs.corr = purity) + } + # Keep the between-CS correlation matrix (not the whole fit) for callers + # that use it to decide whether credible sets are distinct. + csCorr <- tryCatch(fsusieR::cal_cor_cs(tmp, dataX)$cs_cor, error = function(e) NULL) } return(list(sets = sets, cs_corr = csCorr, pip = fit$pip)) } @@ -564,11 +586,64 @@ computeCsTable <- function(fit, dataX, coverage, csInput = c("X", "Xcorr", "fsus #' @return A data frame in the fixed 22-column shape for this fit and method, #' or an empty data frame if nothing is retained. #' @export +# Per-effect (per credible set) variant-level columns from the susie fit. Always +# returns `within_cs_pip` (the variant's alpha in the single effect of its +# assigned primary-coverage CS; NA for non-CS variants -- alpha is a probability, +# no scaling). With fullFit = TRUE it also widens the per-effect matrices, one +# column set per CS: `within_cs_pip_` (alpha) and -- unless fullFitAlphaOnly -- +# `cs_logbf_` (lbf_variable), `cs_effect_` (mu / X_column_scale_factors) +# and `cs_effect_var_` ((mu2 - mu^2) / scale^2). includeAllCs = TRUE widens +# EVERY effect (label `L`), else only effects that produced a passing CS +# (label `cs`, matching the cs_ columns). alpha/mu/mu2/lbf are L x p +# per-effect matrices (mu/mu2 already condition-sliced upstream); missing on a +# trimmed / fSuSiE fit, in which case the values are NA. +# @noRd +.fullFitColumns <- function(alpha, mu, mu2, lbfMat, scale, primaryCsPos, effectOf, + fullFit = FALSE, fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { + nV <- if (is.null(alpha) || length(dim(alpha)) < 2L) length(primaryCsPos) else ncol(alpha) + withinPip <- rep(NA_real_, nV) + hasAlpha <- !is.null(alpha) && length(dim(alpha)) == 2L && nrow(alpha) > 0L + if (hasAlpha && length(primaryCsPos) == nV && length(effectOf) > 0L) { + for (v in seq_len(nV)) { + cp <- primaryCsPos[[v]] + if (!is.na(cp) && cp >= 1L && cp <= length(effectOf)) { + L <- effectOf[[cp]] + if (!is.na(L) && L >= 1L && L <= nrow(alpha)) withinPip[[v]] <- alpha[L, v] + } + } + } + cols <- data.frame(within_cs_pip = withinPip, stringsAsFactors = FALSE) + if (!isTRUE(fullFit) || !hasAlpha) return(cols) + if (isTRUE(includeAllCs)) { + effs <- seq_len(nrow(alpha)); labs <- paste0("L", effs) + } else { + keep <- which(!is.na(effectOf) & effectOf >= 1L & effectOf <= nrow(alpha)) + effs <- effectOf[keep]; labs <- paste0("cs", keep) + } + if (is.null(scale) || length(scale) != nV) scale <- rep(1, nV) + for (i in seq_along(effs)) { + L <- effs[[i]]; lab <- labs[[i]] + cols[[paste0("within_cs_pip_", lab)]] <- alpha[L, ] + if (!isTRUE(fullFitAlphaOnly)) { + if (!is.null(lbfMat) && L <= nrow(lbfMat)) + cols[[paste0("cs_logbf_", lab)]] <- lbfMat[L, ] + if (!is.null(mu) && L <= nrow(mu)) + cols[[paste0("cs_effect_", lab)]] <- mu[L, ] / scale + if (!is.null(mu) && !is.null(mu2) && L <= nrow(mu2)) + cols[[paste0("cs_effect_var_", lab)]] <- (mu2[L, ] - mu[L, ]^2) / scale^2 + } + } + cols +} + buildTopLoci <- function(fit, csTables, variantNames, sumstats = NULL, af = NULL, method, signalCutoff = 0, dataX = NULL, dataY = NULL, otherQuantities = NULL, - region = NULL, conditionIdx = NULL) { + region = NULL, conditionIdx = NULL, + fullFit = FALSE, fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { if (missing(method) || is.null(method) || length(method) != 1L || is.na(method) || !nzchar(method)) { stop("buildTopLoci: `method` is required (e.g. \"susie\", \"susieInf\").") @@ -611,6 +686,16 @@ buildTopLoci <- function(fit, csTables, variantNames, sumstats = NULL, postSd <- if (!is.null(mu2) && all(dim(alpha) == dim(mu2))) { sqrt(pmax(colSums(alpha * mu2) - postMean^2, 0)) } else rep(NA_real_, length(variantNames)) + # Per-variant log Bayes factor: the strongest single-effect lbf across effects + # (from `lbf_variable`, or fSuSiE's `lBF`). NA when the fit carries no lbf + # matrix. Replaces the legacy semicolon-joined per-effect `log10_base_factor` + # with one tidy numeric per variant. + lbfMat <- .asLbfMatrix(fit) + logBF <- if (!is.null(lbfMat) && ncol(lbfMat) == length(variantNames)) { + apply(lbfMat, 2, function(x) { + x <- x[is.finite(x)]; if (length(x) == 0L) NA_real_ else max(x) + }) + } else rep(NA_real_, length(variantNames)) # Parse variant IDs into chrom/pos/A1/A2 (one row per variant). parsed <- tryCatch( @@ -660,46 +745,139 @@ buildTopLoci <- function(fit, csTables, variantNames, sumstats = NULL, } out } - idx95 <- csIdxAtCoverage(0.95) - idx70 <- csIdxAtCoverage(0.70) - idx50 <- csIdxAtCoverage(0.50) - - # 0.95-coverage CS purity, per-variant (0 for non-CS variants). - purityPerCs <- { - h <- which(abs(coverageValues - 0.95) < 1e-12) - if (length(h) > 0L) .csPurityVec(csTables[[h[1L]]]) else numeric() + # Per-variant CS purity at a coverage (0 for non-CS variants). Purity + # (min.abs.corr) is a CS-quality measure, independent of the coverage + # (confidence) level; the accessors expose an independent `minPurity` filter + # over these columns. + purityAtCoverage <- function(targetCov, idxVec) { + h <- which(abs(coverageValues - targetCov) < 1e-12) + pv <- if (length(h) > 0L) .csPurityVec(csTables[[h[1L]]]) else numeric() + vapply(idxVec, function(i) { + if (i <= 0L || i > length(pv)) return(0) + v <- pv[i]; if (is.na(v)) 0 else as.numeric(v) + }, numeric(1)) + } + # Derive CS membership + purity for EVERY coverage the pipeline actually + # produced (attr(csTables, "coverage")), rather than assuming fixed + # 0.95/0.70/0.50 levels — otherwise a non-default secondaryCoverage would be + # silently dropped. Ordered high -> low so the primary CS leads; the column + # names match getCs's `cs_` lookup. + covSorted <- sort(unique(coverageValues[is.finite(coverageValues)]), + decreasing = TRUE) + csIdxByCov <- lapply(covSorted, csIdxAtCoverage) + csPurityByCov <- Map(purityAtCoverage, covSorted, csIdxByCov) + csColNames <- paste0("cs_", covSorted * 100) + + # Per-condition posterior conditional effect + local false sign rate for + # multivariate (mvsusie) fits. `conditional_effect` is the effect conditional + # on the variant being causal (coef / pip) for this condition; `lfsr` is the + # variant's conditional lfsr within its 0.95 credible set for this condition + # (from the fit's `clfsr`, an L x variants x conditions array). Both stay NA + # for univariate fits (conditionIdx = NULL) and are only attached to `out` + # below when a conditionIdx is supplied, so the univariate schema is + # unchanged (the projector whitelist picks them up only when present). + condEffect <- rep(NA_real_, nV) + condLfsr <- rep(NA_real_, nV) + if (!is.null(conditionIdx)) { + # The raw (pre-trim) mvsusie fit exposes coefficients via coef.mvsusie() + # and stores lfsr as `conditional_lfsr`; the trimmed fit stores `$coef` + # (variants x conditions, intercept dropped) and `$clfsr`. Accept either. + coefMat <- if (!is.null(fit$coef)) { + as.matrix(fit$coef) + } else if (identical(method, "mvsusie") && + requireNamespace("mvsusieR", quietly = TRUE)) { + cm <- tryCatch(mvsusieR::coef.mvsusie(fit), error = function(e) NULL) + if (!is.null(cm)) as.matrix(cm)[-1L, , drop = FALSE] else NULL + } else NULL + if (!is.null(coefMat) && nrow(coefMat) == nV && ncol(coefMat) >= conditionIdx) { + pipVec <- as.numeric(fit$pip) + condEffect <- ifelse(pipVec > 0, coefMat[, conditionIdx] / pipVec, NA_real_) + } + clf <- if (!is.null(fit$clfsr)) fit$clfsr else fit$conditional_lfsr + if (!is.null(clf) && length(dim(clf)) == 3L && dim(clf)[3L] >= conditionIdx && + length(covSorted) > 0L) { + # Map each variant to its effect (L) via the PRIMARY (highest-coverage) + # credible set, then read that effect's conditional lfsr for this condition. + hPrim <- which(abs(coverageValues - covSorted[1L]) < 1e-12) + if (length(hPrim) > 0L) { + setsPrim <- csTables[[hPrim[1L]]]$sets$cs + if (!is.null(setsPrim) && length(setsPrim) > 0L) { + effectOf <- suppressWarnings(as.integer(sub("^L", "", names(setsPrim)))) + for (csPos in seq_along(setsPrim)) { + L <- effectOf[csPos] + if (is.na(L) || L < 1L || L > dim(clf)[1L]) next + vi <- as.integer(setsPrim[[csPos]]) + vi <- vi[vi >= 1L & vi <= nV] + if (length(vi) > 0L) condLfsr[vi] <- as.numeric(clf[L, vi, conditionIdx]) + } + } + } + } } - cs95Purity <- vapply(idx95, function(i) { - if (i <= 0L || i > length(purityPerCs)) return(0) - v <- purityPerCs[i]; if (is.na(v)) 0 else as.numeric(v) - }, numeric(1)) methodTag <- .camelToSnakeMethod(method) - out <- data.frame( - variant_id = as.character(variantNames), - chrom = parsed$chrom, - pos = as.integer(parsed$pos), - A1 = parsed$A1, - A2 = parsed$A2, - N = rep(fitN, nV), - af = if (is.null(af)) rep(NA_real_, nV) else as.numeric(af), - marginal_beta = marginalBeta, - marginal_se = marginalSe, - marginal_z = marginalZ, - marginal_p = marginalP, - pip = as.numeric(fit$pip), - posterior_mean = postMean, - posterior_sd = postSd, - cs_95 = paste0(methodTag, "_", idx95), - cs_70 = paste0(methodTag, "_", idx70), - cs_50 = paste0(methodTag, "_", idx50), - cs_95_purity = cs95Purity, - method = rep(method, nV), - gene = rep(fitGene, nV), - event = rep(fitEvent, nV), - grange_start = rep(grange[["start"]], nV), - grange_end = rep(grange[["end"]], nV), - stringsAsFactors = FALSE) + # Dynamic CS block: memberships (cs_) then purities (cs__purity), one + # pair per coverage present, high -> low. For the default coverages this is + # cs_95, cs_70, cs_50, cs_95_purity, cs_70_purity, cs_50_purity. + csList <- c( + setNames(lapply(csIdxByCov, function(ix) paste0(methodTag, "_", ix)), csColNames), + setNames(csPurityByCov, paste0(csColNames, "_purity"))) + csBlock <- if (length(csList) > 0L) { + as.data.frame(csList, stringsAsFactors = FALSE, check.names = FALSE) + } else data.frame(matrix(nrow = nV, ncol = 0)) + + # Per-CS variant-level (within_cs_pip + optional fullFit wide) block. Map each + # variant to the effect of its primary-coverage CS (position -> effect via the + # sets$cs names "L"), then read the per-effect fit matrices. + primaryCsPos <- if (length(csIdxByCov) > 0L) csIdxByCov[[1L]] else integer(nV) + effectOfPrim <- integer(0) + if (length(covSorted) > 0L) { + hP <- which(abs(coverageValues - covSorted[1L]) < 1e-12) + if (length(hP) > 0L) { + spP <- csTables[[hP[1L]]]$sets$cs + if (!is.null(spP) && length(spP) > 0L) + effectOfPrim <- suppressWarnings(as.integer(sub("^L", "", names(spP)))) + } + } + fullFitBlock <- .fullFitColumns( + alpha, mu, mu2, .asLbfMatrix(fit), fit$X_column_scale_factors, + primaryCsPos, effectOfPrim, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) + out <- cbind( + data.frame( + variant_id = as.character(variantNames), + chrom = parsed$chrom, + pos = as.integer(parsed$pos), + A1 = parsed$A1, + A2 = parsed$A2, + N = rep(fitN, nV), + af = if (is.null(af)) rep(NA_real_, nV) else as.numeric(af), + marginal_beta = marginalBeta, + marginal_se = marginalSe, + marginal_z = marginalZ, + marginal_p = marginalP, + pip = as.numeric(fit$pip), + posterior_mean = postMean, + posterior_sd = postSd, + logBF = logBF, + stringsAsFactors = FALSE), + csBlock, + fullFitBlock, + data.frame( + method = rep(method, nV), + gene = rep(fitGene, nV), + event = rep(fitEvent, nV), + grange_start = rep(grange[["start"]], nV), + grange_end = rep(grange[["end"]], nV), + stringsAsFactors = FALSE)) + # Attach per-condition posterior quantities only for multi-condition fits, so + # the univariate top-loci schema is unchanged (kept long + numeric: one row + # per (variant, condition), never a semicolon-collapsed string). + if (!is.null(conditionIdx)) { + out$conditional_effect <- condEffect + out$lfsr <- condLfsr + } if (!is.null(signalCutoff) && signalCutoff > 0) { keep <- !is.na(out$pip) & out$pip > signalCutoff out <- out[keep, , drop = FALSE] @@ -760,10 +938,14 @@ buildTopLoci <- function(fit, csTables, variantNames, sumstats = NULL, pip = numeric(), posterior_mean = numeric(), posterior_sd = numeric(), + logBF = numeric(), cs_95 = character(), cs_70 = character(), cs_50 = character(), cs_95_purity = numeric(), + cs_70_purity = numeric(), + cs_50_purity = numeric(), + within_cs_pip = numeric(), method = character(), gene = character(), event = character(), @@ -1863,7 +2045,8 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { secondaryCoverage, signalCutoff, minAbsCorr, methodArgs, verbose, ctx, tid, cvFolds = 0, cvThreads = 1, samplePartition = NULL, - af = NULL) { + af = NULL, fullFit = FALSE, fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) infFit <- NULL if (chainLocal$runInf) { @@ -1891,7 +2074,8 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { out[[tk]] <- .fmPostprocessOne( fit = fit, method = tk, dataX = X, dataY = y, coverage = coverage, secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, - minAbsCorr = minAbsCorr, af = af, csInput = "X") + minAbsCorr = minAbsCorr, af = af, csInput = "X", fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) } # Per-fold cross-validation across the fitted univariate methods; attach # each method's out-of-fold predictions to its entry. @@ -1916,7 +2100,9 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { # they push the returned entries (tuple shape) and the progress `label`. .fmFitRssBlock <- function(z, R, n, toRun, addSusieInf, coverage, secondaryCoverage, signalCutoff, minAbsCorr, - methodArgs, verbose, label, af = NULL) { + methodArgs, verbose, label, af = NULL, + fullFit = FALSE, fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { chainLocal <- .fmResolveSusieChain(toRun, addSusieInf) infFit <- NULL if (chainLocal$runInf) { @@ -1950,7 +2136,8 @@ mergeSusieCs <- function(fineMappingResult, coverage = 0.95) { fit = fit, method = "susieRss", dataX = R, dataY = list(z = z), coverage = coverage, secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, minAbsCorr = minAbsCorr, af = af, - csInput = "Xcorr") + csInput = "Xcorr", fullFit = fullFit, + fullFitAlphaOnly = fullFitAlphaOnly, includeAllCs = includeAllCs) } out } diff --git a/R/fsusieAccessors.R b/R/fsusieAccessors.R new file mode 100644 index 00000000..21610331 --- /dev/null +++ b/R/fsusieAccessors.R @@ -0,0 +1,190 @@ +#' @include AllGenerics.R AllClasses.R FineMappingEntry.R tupleSelectors.R +NULL + +# Detect an untrimmed fSuSiE (susiF) fit carrying the wavelet slots that the +# credible band needs. A trimmed fit drops these, so we degrade to empty. +# @noRd +.isFsusieFit <- function(fit) { + !is.null(fit) && is.list(fit) && + !is.null(fit$fitted_wc2) && !is.null(fit$fitted_func) && + !is.null(fit$outing_grid) && !is.null(fit$alpha) +} + +# Populate `obj$cred_band` via fsusieR's wavethresh/GenW band computation. That +# function is registered as an S3 method but NOT exported, and the exported +# affected_reg() depends on cred_band already being populated, so this internal +# call is the only path that works across all post_processing modes. Guarded so +# an upstream fsusieR change surfaces as a clear error, not a silent NULL. +# @noRd +.fsusiePopulateCredibleBand <- function(fit) { + fn <- tryCatch(get("update_cal_credible_band.susiF", envir = asNamespace("fsusieR")), + 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) + stop("fsusieR's internal update_cal_credible_band.susiF not found; cannot compute the ", + "fSuSiE credible band (upstream fsusieR API changed).") + # nocov end + } + indxLst <- fsusieR::gen_wavelet_indx(log2(length(fit$outing_grid))) + fn(fit, indxLst) +} + +# Chromosome of the fit's variants (matches getTopLoci's `chrom`, no "chr"). +# @noRd +.fsusieChrom <- function(fit) { + vid <- names(fit$csd_X) + if (is.null(vid) || length(vid) == 0L) return(NA_character_) + tryCatch(parseVariantId(vid[1])$chrom, error = function(e) NA_character_) +} + +.emptyCredibleBand <- function() { + data.frame(cs = character(), chrom = character(), pos = numeric(), + effect = numeric(), lower = numeric(), upper = numeric(), + stringsAsFactors = FALSE) +} + +# @noRd +.fsusieCredibleBandFit <- function(fit) { + if (!.isFsusieFit(fit)) return(.emptyCredibleBand()) + fit <- .fsusiePopulateCredibleBand(fit) + grid <- as.numeric(fit$outing_grid) + chrom <- .fsusieChrom(fit) + parts <- lapply(seq_along(fit$cred_band), function(l) { + band <- fit$cred_band[[l]] + eff <- fit$fitted_func[[l]] + if (is.null(band) || is.null(eff)) return(NULL) + data.frame(cs = paste0("fsusie_", l), chrom = chrom, pos = grid, + effect = as.numeric(eff), + lower = as.numeric(band[2, ]), upper = as.numeric(band[1, ]), + stringsAsFactors = FALSE) + }) + parts <- parts[!vapply(parts, is.null, logical(1))] + if (length(parts) == 0L) return(.emptyCredibleBand()) + do.call(rbind, parts) +} + +# Map each fit-effect index (1..L, as affected_reg's `CS`) to pecotmr's canonical +# CS label + purity. The raw fSuSiE fit stores no purity (fsusieR computes it +# from the genotype matrix, which the fit does not retain), so the canonical +# value is `cs_95_purity` in the entry's topLoci. Matching is by the CS's variant +# MEMBERSHIP (not by index), which is robust to pecotmr's CS filtering/renumbering. +# @noRd +.fsusieCsMapFromTopLoci <- function(fit, topLoci) { + L <- length(fit$cs) + label <- stats::setNames(paste0("fsusie_", seq_len(L)), seq_len(L)) + purity <- stats::setNames(rep(NA_real_, L), seq_len(L)) + vids <- names(fit$csd_X) + if (is.null(topLoci) || is.null(vids) || + !all(c("cs_95", "cs_95_purity", "variant_id") %in% names(topLoci))) + return(list(label = label, purity = purity)) + retained <- unique(topLoci$cs_95[!grepl("_0$", topLoci$cs_95)]) + for (lab in retained) { + inLab <- topLoci$cs_95 == lab + kVars <- as.character(topLoci$variant_id[inLab]) + kPurit <- as.numeric(topLoci$cs_95_purity[inLab][1]) + for (l in seq_len(L)) { + fv <- fit$cs[[l]] + if (is.numeric(fv)) fv <- vids[as.integer(fv)] + fv <- as.character(fv) + if (length(fv) > 0L && setequal(fv, kVars)) { + label[[as.character(l)]] <- lab + purity[[as.character(l)]] <- kPurit + break + } + } + } + list(label = label, purity = purity) +} + +# @noRd +.fsusieAffectedRegionsFit <- function(fit, topLoci = NULL) { + if (!.isFsusieFit(fit)) return(GenomicRanges::GRanges()) + fit <- .fsusiePopulateCredibleBand(fit) + reg <- tryCatch(fsusieR::affected_reg(fit), error = function(e) NULL) + if (is.null(reg) || nrow(reg) == 0L) return(GenomicRanges::GRanges()) + reg <- as.data.frame(reg) + chrom <- .fsusieChrom(fit) + grid <- as.numeric(fit$outing_grid) + csMap <- .fsusieCsMapFromTopLoci(fit, topLoci) + csKey <- as.character(reg$CS) + # Effect direction over each region (sign of the fitted effect curve), which + # upstream affected_reg() collapses away. + direction <- vapply(seq_len(nrow(reg)), function(i) { + inRange <- which(grid >= reg$Start[i] & grid <= reg$End[i]) + eff <- fit$fitted_func[[reg$CS[i]]] + if (length(inRange) == 0L || is.null(eff)) return(NA_character_) + s <- sign(mean(as.numeric(eff)[inRange], na.rm = TRUE)) + if (is.na(s) || s == 0) NA_character_ else if (s > 0) "pos" else "neg" + }, character(1)) + GenomicRanges::GRanges( + seqnames = paste0("chr", sub("^chr", "", chrom)), + ranges = IRanges::IRanges(start = as.integer(reg$Start), end = as.integer(reg$End)), + cs = unname(csMap$label[csKey]), purity = unname(csMap$purity[csKey]), + direction = direction) +} + +#' fSuSiE credible band (fitted effect + uncertainty band) +#' +#' For a functional-SuSiE (\code{fsusieR::susiF}) fine-mapping entry, returns the +#' fitted effect curve and its credible band over the functional grid, one row +#' per (credible set, grid position). Wraps the upstream fSuSiE band computation +#' (fsusieR's internal \code{update_cal_credible_band.susiF} + \code{get_fitted_effect}). +#' Requires an UNtrimmed fit (the wavelet slots are dropped by trimming); +#' degrades to zero rows for non-fSuSiE or trimmed fits. +#' +#' @param x A \code{FineMappingEntry} or \code{FineMappingResultBase}. +#' @param ... Ignored. +#' @return A long \code{data.frame}: \code{cs, chrom, pos, effect, lower, upper} +#' (the collection method additionally carries the entry identity columns). +#' @seealso \code{\link{fsusieAffectedRegions}} +#' @export +setGeneric("fsusieCredibleBand", function(x, ...) standardGeneric("fsusieCredibleBand")) + +#' @rdname fsusieCredibleBand +#' @export +setMethod("fsusieCredibleBand", "FineMappingEntry", + function(x, ...) .fsusieCredibleBandFit(getSusieFit(x))) + +#' @rdname fsusieCredibleBand +#' @export +setMethod("fsusieCredibleBand", "FineMappingResultBase", + function(x, ...) .fmrAggregateView(x, perEntry = function(e) fsusieCredibleBand(e))) + +#' fSuSiE affected genomic regions +#' +#' The sub-intervals of the functional grid where a credible set's band excludes +#' zero (the genomic footprint of each fSuSiE effect), from the upstream +#' \code{fsusieR::affected_reg}. Returns a \code{GRanges} with the credible-set +#' label, its purity, and the effect \code{direction} (\code{"pos"}/\code{"neg"}; +#' upstream discards it). Requires an UNtrimmed fit; empty otherwise. +#' +#' @param x A \code{FineMappingEntry} or \code{FineMappingResultBase}. +#' @param ... Ignored. +#' @return A \code{GRanges} of affected intervals with mcols \code{cs}, +#' \code{purity}, \code{direction} (plus entry identity for the collection). +#' @seealso \code{\link{fsusieCredibleBand}} +#' @export +setGeneric("fsusieAffectedRegions", function(x, ...) standardGeneric("fsusieAffectedRegions")) + +#' @rdname fsusieAffectedRegions +#' @export +setMethod("fsusieAffectedRegions", "FineMappingEntry", + function(x, ...) .fsusieAffectedRegionsFit(getSusieFit(x), topLoci = x@topLoci)) + +#' @rdname fsusieAffectedRegions +#' @export +setMethod("fsusieAffectedRegions", "FineMappingResultBase", function(x, ...) { + grs <- lapply(seq_len(nrow(x)), function(i) { + gr <- fsusieAffectedRegions(x$entry[[i]]) + if (length(gr) > 0L) { + S4Vectors::mcols(gr)$study <- as.character(x$study[[i]]) + if ("context" %in% names(x)) S4Vectors::mcols(gr)$context <- as.character(x$context[[i]]) + if ("trait" %in% names(x)) S4Vectors::mcols(gr)$trait <- as.character(x$trait[[i]]) + } + gr + }) + grs <- grs[vapply(grs, length, integer(1)) > 0L] + if (length(grs) == 0L) return(GenomicRanges::GRanges()) + do.call(c, grs) +}) diff --git a/R/getLbf.R b/R/getLbf.R new file mode 100644 index 00000000..c3d186fa --- /dev/null +++ b/R/getLbf.R @@ -0,0 +1,36 @@ +#' @include AllGenerics.R AllClasses.R FineMappingEntry.R tupleSelectors.R +NULL + +#' Per-variant per-effect log Bayes factors (wide) +#' +#' The variant x effect matrix of single-effect log Bayes factors +#' (\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row per +#' variant, one \code{lbf_L} column per effect. The per-variant scalar summary +#' (max across effects) is the \code{logBF} column of \code{\link{getTopLoci}}; +#' this accessor keeps the full per-effect breakdown. Across entries with +#' different effect counts the collection method NA-fills the ragged columns. +#' +#' @param x A \code{FineMappingEntry} or \code{FineMappingResultBase}. +#' @param ... Ignored. +#' @return A \code{data.frame}: \code{variant_id} + \code{lbf_L1..lbf_LL} (the +#' collection method also carries the entry identity columns). +#' @seealso \code{\link{getTopLoci}} (the scalar \code{logBF} column) +#' @export +setGeneric("getLbf", function(x, ...) standardGeneric("getLbf")) + +#' @rdname getLbf +#' @export +setMethod("getLbf", "FineMappingEntry", function(x, ...) { + lbf <- .asLbfMatrix(getSusieFit(x)) + vids <- x@variantIds + if (is.null(lbf) || ncol(lbf) != length(vids)) + return(data.frame(variant_id = character(0), stringsAsFactors = FALSE)) + w <- as.data.frame(t(as.matrix(lbf)), stringsAsFactors = FALSE) + names(w) <- paste0("lbf_L", seq_len(ncol(w))) + cbind(data.frame(variant_id = as.character(vids), stringsAsFactors = FALSE), w) +}) + +#' @rdname getLbf +#' @export +setMethod("getLbf", "FineMappingResultBase", + function(x, ...) .fmrAggregateView(x, perEntry = function(e) getLbf(e))) diff --git a/R/gwasSumStats.R b/R/gwasSumStats.R index 747cafe8..b53db08f 100644 --- a/R/gwasSumStats.R +++ b/R/gwasSumStats.R @@ -15,6 +15,9 @@ setClass("GwasSumStats", contains = "SumStatsBase", validity = function(object) { errors <- character() + if (!is.null(object@ldSketch) && + !methods::is(object@ldSketch, "GenotypeHandle")) + errors <- c(errors, "'ldSketch' must be a GenotypeHandle or NULL") required <- c("study", "entry") missingCols <- setdiff(required, names(object)) if (length(missingCols) > 0L) @@ -45,8 +48,10 @@ setClass("GwasSumStats", setMethod("show", "GwasSumStats", function(object) { cat(sprintf("GwasSumStats: %d studies, genome build %s\n", nrow(object), object@genome)) - cat(sprintf(" LD sketch: %s @ %s\n", - object@ldSketch@format, object@ldSketch@path)) + ld <- object@ldSketch + cat(sprintf(" LD sketch: %s\n", + if (is.null(ld)) "none (LD-free)" + else sprintf("%s @ %s", ld@format, ld@path))) }) @@ -97,11 +102,11 @@ NULL #' @param ... Additional per-study columns to attach to the collection. #' @return A \code{GwasSumStats} object. #' @export -GwasSumStats <- function(study, entry, genome, ldSketch, +GwasSumStats <- function(study, entry, genome, ldSketch = NULL, varY = NA_real_, nCase = NULL, nControl = NULL, qcInfo = list(), ...) { - if (missing(study) || missing(entry) || missing(genome) || missing(ldSketch)) { - stop("`study`, `entry`, `genome`, and `ldSketch` are all required.") + if (missing(study) || missing(entry) || missing(genome)) { + stop("`study`, `entry`, and `genome` are all required.") } if (length(genome) != 1L) { stop("`genome` must be a single character string (one build per ", diff --git a/R/h2Annotations.R b/R/h2Annotations.R index c3d7c4df..acb7abb4 100644 --- a/R/h2Annotations.R +++ b/R/h2Annotations.R @@ -10,40 +10,6 @@ #' @include AllGenerics.R NULL -# ============================================================================= -# Constructor -# ============================================================================= - -#' @title Create an AnnotationMatrix Object -#' @description Construct an \code{AnnotationMatrix} from a matrix and metadata. -#' @param annotations A numeric matrix or sparse matrix (SNPs x annotations). -#' @param snpRanges A \code{GRanges} object with SNP positions. -#' @param annotationMeta A data.frame with columns: name, tier, type. -#' @param genome Character, genome build. -#' @return An \code{AnnotationMatrix} object. -#' @export -AnnotationMatrix <- function(annotations, snpRanges, annotationMeta, - genome = "hg19") { - # Validate annotationMeta - if (!is.data.frame(annotationMeta)) - stop("annotationMeta must be a data.frame") - - requiredCols <- c("name", "tier", "type") - if (!all(requiredCols %in% colnames(annotationMeta))) - stop("annotationMeta must have columns: name, tier, type") - - # Set column names on matrix - if (is.null(colnames(annotations))) - colnames(annotations) <- annotationMeta$name - - new("AnnotationMatrix", - snpRanges = snpRanges, - annotations = annotations, - annotationMeta = annotationMeta, - genome = genome - ) -} - # ============================================================================= # Reader method # ============================================================================= @@ -190,40 +156,5 @@ setMethod("readAnnotations", result } -# ============================================================================= -# Annotation subsetting -# ============================================================================= - -#' @title Get Baseline Annotations -#' @description Extract only baseline-tier annotations from an -#' \code{AnnotationMatrix}. -#' @param annot An \code{AnnotationMatrix} object. -#' @return An \code{AnnotationMatrix} with only baseline annotations. -#' @export -getBaseline <- function(annot) { - meta <- getAnnotationMeta(annot) - idx <- meta$tier == "baseline" - AnnotationMatrix( - annotations = getAnnotations(annot)[, idx, drop = FALSE], - snpRanges = getSnpRanges(annot), - annotationMeta = meta[idx, , drop = FALSE], - genome = getGenome(annot) - ) -} - -#' @title Get Candidate Annotations -#' @description Extract only candidate-tier annotations from an -#' \code{AnnotationMatrix}. -#' @param annot An \code{AnnotationMatrix} object. -#' @return An \code{AnnotationMatrix} with only candidate annotations. -#' @export -getCandidates <- function(annot) { - meta <- getAnnotationMeta(annot) - idx <- meta$tier == "candidate" - AnnotationMatrix( - annotations = getAnnotations(annot)[, idx, drop = FALSE], - snpRanges = getSnpRanges(annot), - annotationMeta = meta[idx, , drop = FALSE], - genome = getGenome(annot) - ) -} +# (The AnnotationMatrix() constructor and the getBaseline / getCandidates tier +# accessors now live in R/AnnotationMatrix.R alongside the class definition.) diff --git a/R/h2EstimationWrappers.R b/R/h2EstimationWrappers.R index 60eeadbe..aa491a85 100644 --- a/R/h2EstimationWrappers.R +++ b/R/h2EstimationWrappers.R @@ -319,64 +319,54 @@ standardizeTauStar <- function(tau, tauBlocks, sdAnnot, MRef, h2g) { # DerSimonian-Laird random-effects meta-analysis # ============================================================================= -#' @title Random-Effects Meta-Analysis (DerSimonian-Laird) -#' @description Perform a DerSimonian-Laird random-effects meta-analysis -#' from a set of study-level point estimates and standard errors. +#' @title Random-Effects Meta-Analysis (metafor wrapper) +#' @description Thin convenience wrapper around \code{metafor::rma()}. pecotmr +#' does not implement its own meta-analysis engine -- this helper only guards +#' the degenerate 0- and 1-study cases (where \code{rma} is undefined) and +#' reshapes the \code{metafor} fit into a small list. The between-study +#' variance estimator is chosen by \code{method} and passed straight through. #' @param means Numeric vector of study-level point estimates. #' @param ses Numeric vector of study-level standard errors (must be #' positive and finite). -#' @return A list with: -#' \describe{ -#' \item{mean}{Pooled meta-analytic mean.} -#' \item{se}{Standard error of the pooled mean.} -#' \item{tau2}{Estimated between-study variance.} -#' \item{I2}{Higgins I-squared heterogeneity statistic (proportion of -#' total variance due to between-study variance), in [0, 1].} -#' \item{Q}{Cochran's Q statistic for heterogeneity.} -#' } -#' @keywords internal -metaRandomEffects <- function(means, ses) { +#' @param method Between-study variance estimator forwarded to +#' \code{metafor::rma(method = )} (e.g. \code{"DL"} (default), \code{"REML"}, +#' \code{"ML"}, \code{"EB"}). +#' @return A list with \code{mean}, \code{se}, \code{tau2}, \code{I2} (a [0, 1] +#' proportion) and \code{Q} (Cochran's Q). +#' @importFrom metafor rma +#' @noRd +.rmaMeta <- function(means, ses, method = "DL") { k <- length(means) if (k != length(ses)) { - stop("metaRandomEffects: means and ses must have the same length.") + stop(".rmaMeta: means and ses must have the same length.") } if (k == 0L) { return(list(mean = NA_real_, se = NA_real_, tau2 = NA_real_, I2 = NA_real_, Q = NA_real_)) } if (k == 1L) { - return(list(mean = means[1], se = ses[1], tau2 = 0, - I2 = 0, Q = 0)) + return(list(mean = means[1], se = ses[1], tau2 = 0, I2 = 0, Q = 0)) } if (any(!is.finite(ses) | ses <= 0)) { - stop("metaRandomEffects: all ses must be positive and finite.") - } - - # Fixed-effect weights - wFe <- 1 / ses^2 - - # Fixed-effect pooled estimate - muFe <- sum(wFe * means) / sum(wFe) - - # Cochran's Q - Q <- sum(wFe * (means - muFe)^2) - - # DerSimonian-Laird tau-squared estimator - cDl <- sum(wFe) - sum(wFe^2) / sum(wFe) - tau2 <- max(0, (Q - (k - 1)) / cDl) - - # Random-effects weights - - wRe <- 1 / (ses^2 + tau2) - - # Pooled random-effects estimate - muRe <- sum(wRe * means) / sum(wRe) - seRe <- sqrt(1 / sum(wRe)) - - # Higgins I-squared - I2 <- max(0, (Q - (k - 1)) / Q) - - list(mean = muRe, se = seRe, tau2 = tau2, I2 = I2, Q = Q) + stop(".rmaMeta: all ses must be positive and finite.") + } + + # Delegate the estimator to metafor::rma (metafor is a hard dependency). + # Iterative estimators (REML / ML / EB / ...) can fail to converge on small + # or near-homogeneous inputs; fall back to the closed-form DerSimonian-Laird + # (which never iterates) so callers get a valid random-effects fit instead of + # an error. metafor reports I-squared as a percentage; rescale to [0, 1]. + fit <- tryCatch( + metafor::rma(yi = means, sei = ses, method = method), + error = function(e) { + if (identical(method, "DL")) stop(e) + warning(".rmaMeta: metafor::rma(method = '", method, "') failed (", + conditionMessage(e), "); falling back to DL.", call. = FALSE) + metafor::rma(yi = means, sei = ses, method = "DL") + }) + list(mean = as.numeric(fit$b), se = as.numeric(fit$se), + tau2 = as.numeric(fit$tau2), I2 = as.numeric(fit$I2) / 100, + Q = as.numeric(fit$QE)) } diff --git a/R/jointEngine.R b/R/jointEngine.R index 26cd37b6..a517fe50 100644 --- a/R/jointEngine.R +++ b/R/jointEngine.R @@ -81,12 +81,19 @@ NULL e } -# Genomic anchor of one trait for the `region` provenance column: the trait's -# own coordinates for a QtlDataset (phenotype rowRanges), or the variant-span -# window of the matching entry for a QtlSumStats (an approximation -- summary -# stats carry no gene coordinate). Returns a length-1 GRanges, or NULL when the -# anchor cannot be determined (the accumulator then records a chrUn sentinel). -.jointTraitRegion <- function(data, context, trait) { +# --- Trait-position and fine-mapping-region provenance ---------------------- +# Two DISTINCT per-row anchors, kept separate because they mean different things +# and diverge by input type: +# traitPos = the bare trait position, NO cis-window. QtlDataset -> the trait's +# own phenotype rowRanges; QtlSumStats -> the SUPPLIED `traitPos` +# column (NULL when absent -- the true position cannot be inferred +# from summary statistics alone). +# region = the fine-mapping window. QtlDataset -> traitPos +/- cisWindow; +# QtlSumStats -> the entry's variant span (sumstats carry no +# cis-window, so the fitted span IS the region). +# Each returns a length-1 GRanges, or NULL when the anchor is unavailable (the +# accumulator / builder then records a chrUn sentinel). +.traitPosFor <- function(data, context, trait) { if (methods::is(data, "QtlDataset")) { se <- tryCatch(getPhenotypes(data, contexts = context), error = function(e) NULL) @@ -95,6 +102,28 @@ NULL if (!(trait %in% names(rr))) return(NULL) return(GenomicRanges::granges(rr[trait])[1L]) } + if (methods::is(data, "QtlSumStats")) { + if (!("traitPos" %in% names(data))) return(NULL) + idx <- which(as.character(data$context) == context & + as.character(data$trait) == trait) + if (length(idx) == 0L) return(NULL) + tp <- data$traitPos[idx[[1L]]] + if (length(tp) == 0L) return(NULL) + return(GenomicRanges::granges(tp)[1L]) + } + NULL +} + +.fitRegionFor <- function(data, context, trait, cisWindow = NULL) { + if (methods::is(data, "QtlDataset")) { + tp <- .traitPosFor(data, context, trait) + if (is.null(tp)) return(NULL) + w <- if (is.null(cisWindow)) 0L else as.integer(cisWindow) + return(GenomicRanges::GRanges( + as.character(GenomicRanges::seqnames(tp))[[1L]], + IRanges::IRanges(max(1L, GenomicRanges::start(tp) - w), + GenomicRanges::end(tp) + w))) + } if (methods::is(data, "QtlSumStats")) { idx <- which(as.character(data$context) == context & as.character(data$trait) == trait) @@ -109,6 +138,34 @@ NULL NULL } +# Vectorised per-row anchors for the pushRow builders: map the scalar helper +# over aligned (context, trait) vectors and assemble ONE GRanges of length n, +# using a chrUn sentinel where the anchor is unavailable. Built from plain +# chr/start/end vectors so mixed seqlevels never trip seqinfo merging. +.anchorVector <- function(data, contexts, traits, + kind = c("traitPos", "region"), cisWindow = NULL) { + kind <- match.arg(kind) + n <- length(traits) + chrs <- rep("chrUn", n); starts <- rep(1L, n); ends <- rep(1L, n) + anyFound <- FALSE + for (i in seq_len(n)) { + g <- if (kind == "traitPos") .traitPosFor(data, contexts[[i]], traits[[i]]) + else .fitRegionFor(data, contexts[[i]], traits[[i]], cisWindow) + if (!is.null(g)) { + anyFound <- TRUE + chrs[i] <- as.character(GenomicRanges::seqnames(g))[[1L]] + starts[i] <- GenomicRanges::start(g)[[1L]] + ends[i] <- GenomicRanges::end(g)[[1L]] + } + } + # Nothing resolved (e.g. a QtlSumStats with no supplied traitPos): return NULL + # so the builder omits the column entirely and getTraitPosition() reports NA, + # rather than a column full of chrUn sentinels. + if (!anyFound) return(NULL) + GenomicRanges::GRanges(chrs, + IRanges::IRanges(start = starts, end = pmax(ends, starts))) +} + # ---- fitters (fitJointGroup) ------------------------------------------------ # (individual, fine-mapping) -> mvSuSiE joint fit + honest per-fold CV prior. @@ -149,7 +206,9 @@ setMethod("fitJointGroup", signature("IndividualJointGroup", "FmJointPipeline"), fit = fit, method = "fsusie", dataX = Xc, dataY = NULL, conditionIdx = r, coverage = cfg$coverage, secondaryCoverage = cfg$secondaryCoverage, signalCutoff = cfg$signalCutoff, minAbsCorr = cfg$minAbsCorr, - csInput = "fsusie") + csInput = "fsusie", + fullFit = cfg$fullFit, fullFitAlphaOnly = cfg$fullFitAlphaOnly, + includeAllCs = cfg$includeAllCs) if (!is.null(cvM)) e <- .fmAttachCv(e, .fmSliceCvCondition(cvM, r)) e })) @@ -220,7 +279,9 @@ setMethod("fitJointGroup", signature("IndividualJointGroup", "FmJointPipeline"), fit = fit, method = "mvsusie", dataX = Xc, dataY = NULL, conditionIdx = r, coverage = cfg$coverage, secondaryCoverage = cfg$secondaryCoverage, signalCutoff = cfg$signalCutoff, minAbsCorr = cfg$minAbsCorr, - csInput = "X") + csInput = "X", + fullFit = cfg$fullFit, fullFitAlphaOnly = cfg$fullFitAlphaOnly, + includeAllCs = cfg$includeAllCs) if (!is.null(cvM)) e <- .fmAttachCv(e, .fmSliceCvCondition(cvM, r)) e }) @@ -257,7 +318,9 @@ setMethod("fitJointGroup", signature("SumStatsJointGroup", "FmJointPipeline"), fit = fit, method = "mvsusie", dataX = group@R, dataY = NULL, conditionIdx = r, coverage = cfg$coverage, secondaryCoverage = cfg$secondaryCoverage, signalCutoff = cfg$signalCutoff, - minAbsCorr = cfg$minAbsCorr, csInput = "Xcorr")) + minAbsCorr = cfg$minAbsCorr, csInput = "Xcorr", + fullFit = cfg$fullFit, fullFitAlphaOnly = cfg$fullFitAlphaOnly, + includeAllCs = cfg$includeAllCs)) }) # Reshape a twasWeightsCv() result into the single joint entry's cvResult: the @@ -746,12 +809,17 @@ setMethod("construct", "TwasJointPipeline", if (is.null(e)) next ctx <- as.character(cond$context[[i]]) tid <- as.character(cond$trait[[i]]) - reg <- .jointTraitRegion(data, ctx, tid) + # region = the fine-mapping window (cis-window-expanded for a QtlDataset, + # variant span for a QtlSumStats); traitPos = the bare trait position + # (NULL when a QtlSumStats caller supplied none -> the column is omitted + # and getTraitPosition() reports NA). + reg <- .fitRegionFor(data, ctx, tid, args$cisWindow) + tpos <- .traitPosFor(data, ctx, tid) rows$add(study = as.character(cond$study[[i]]), context = ctx, trait = tid, method = method, entry = e, jointStudies = js, jointContexts = jc, jointTraits = jt, - region = reg) + region = reg, traitPos = tpos) } } # Twas: resolve this group's fine-mapping fits + CV (keyed on its first diff --git a/R/jointSpecification.R b/R/jointSpecification.R index 1850f54d..f24b4773 100644 --- a/R/jointSpecification.R +++ b/R/jointSpecification.R @@ -861,14 +861,22 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { list(ldSketch = NULL))) } -# The three optional joint-key columns (jointStudies / jointContexts / -# jointTraits) of a per-tuple result row, as a named list (NULL for any absent -# column). Spliced into the QtlFineMappingResult / TwasWeights constructors. +# The optional passthrough columns of a per-tuple result row, as a named list +# (NULL for any absent column): the three joint-key columns (jointStudies / +# jointContexts / jointTraits) plus the GRanges provenance columns (region / +# traitPos). Spliced into the QtlFineMappingResult / TwasWeights constructors so +# by-key / cross-study rebuilds preserve them. .jointCols <- function(df) { - pick <- function(nm) if (nm %in% names(df)) as.character(df[[nm]]) else NULL + pick <- function(nm) if (nm %in% names(df)) as.character(df[[nm]]) else NULL + # region / traitPos are GRanges provenance columns: carry them through + # uncoerced so by-key / cross-study rebuilds keep the fine-mapping window and + # trait position instead of silently dropping them. + pickCol <- function(nm) if (nm %in% names(df)) df[[nm]] else NULL list(jointStudies = pick("jointStudies"), jointContexts = pick("jointContexts"), - jointTraits = pick("jointTraits")) + jointTraits = pick("jointTraits"), + region = pickCol("region"), + traitPos = pickCol("traitPos")) } # Shared tail of the MultiStudyQtlDataset fineMapping / twasWeights pipeline @@ -951,7 +959,10 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cvFolds = 0, cvThreads = 1, samplePartition = NULL, pipCutoffToSkip = 0, - fineMappingResult = NULL) { + fineMappingResult = NULL, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { # Run the joint dispatch once per region block, then merge per # (study, context, trait, method) across regions. A single block (cis or # jointRegions=TRUE concatenated) returns its result directly. @@ -964,7 +975,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, pipCutoffToSkip = pipCutoffToSkip, - fineMappingResult = fineMappingResult) + fineMappingResult = fineMappingResult, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs) }) perRegion <- Filter(Negate(is.null), perRegion) if (length(perRegion) == 0L) return(NULL) @@ -985,7 +998,10 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { cvFolds = 0, cvThreads = 1, samplePartition = NULL, pipCutoffToSkip = 0, - fineMappingResult = NULL) { + fineMappingResult = NULL, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { # Engine routing (jointEngine.R); one region block (the caller loops regions). .jointRejectStudyOnIndividual(parsedJointSpec) pipeline <- new("FmJointPipeline", config = list( @@ -993,7 +1009,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { signalCutoff = signalCutoff, minAbsCorr = minAbsCorr, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, cvFolds = cvFolds, cvThreads = cvThreads, samplePartition = samplePartition, - verbose = verbose, ldSketch = NULL)) + verbose = verbose, ldSketch = NULL, + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs)) .runJointSpecs(parsedJointSpec, data, dataForm = "individual", pipeline = pipeline, jointMethods = intersect(methods, c("mvsusie", "fsusie")), contexts = contexts, traitIds = traitIds, @@ -1016,7 +1034,10 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { methodArgs = list(), twasWeights = NULL, dataDrivenPriorWeightsCutoff = 1e-10, - fineMappingResult = NULL) { + fineMappingResult = NULL, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE) { # Engine routing (jointEngine.R): the marker carries the fine-mapping config # and result type; the dispatch table + .runJointCell replace the per-axis # switch + the cross-context/trait/study/composed leaf dispatchers. RSS has no @@ -1025,7 +1046,9 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { coverage = coverage, secondaryCoverage = secondaryCoverage, signalCutoff = signalCutoff, minAbsCorr = minAbsCorr, dataDrivenPriorWeightsCutoff = dataDrivenPriorWeightsCutoff, - cvFolds = 0L, verbose = verbose, ldSketch = getLdSketch(data))) + cvFolds = 0L, verbose = verbose, ldSketch = getLdSketch(data), + fullFit = fullFit, fullFitAlphaOnly = fullFitAlphaOnly, + includeAllCs = includeAllCs)) .runJointSpecs(parsedJointSpec, data, dataForm = "sumstats", pipeline = pipeline, jointMethods = intersect(methods, c("mvsusie", "fsusie")), contexts = contexts, traitIds = traitIds, @@ -1128,10 +1151,14 @@ validateMethodsVsJointSpec <- function(methodsParsed, jointSpecParsed) { keep <- !vapply(perRegion, is.null, logical(1)) .twasMergeRegionEntries(perRegion[keep], regionLabels[keep]) }) - TwasWeights( - study = as.character(base$study), context = as.character(base$context), - trait = as.character(base$trait), method = as.character(base$method), - entry = mergedEntries) + # Passthrough columns (joint keys + region + traitPos) are per-row properties + # of `base`, which aligns row-for-row with mergedEntries; splice them so a + # multi-region merge preserves provenance instead of dropping it. + do.call(TwasWeights, c( + list(study = as.character(base$study), context = as.character(base$context), + trait = as.character(base$trait), method = as.character(base$method), + entry = mergedEntries), + .jointCols(base))) } .twasDispatchJointSpecsQtlDataset <- function(parsedJointSpec, data, diff --git a/R/ld.R b/R/ld.R index 8bfe4c26..725d42ad 100644 --- a/R/ld.R +++ b/R/ld.R @@ -543,6 +543,11 @@ loadLdFromGenotype <- function(genotypePath, region, .ldFromSketch <- function(ldSketch, variantIds, label = ".ldFromSketch", onMissing = c("error", "drop")) { + if (is.null(ldSketch)) { + stop(sprintf(paste0("%s: the SumStats/collection carries no ldSketch ", + "(ldSketch = NULL); this step needs an LD reference."), + label)) + } if (!methods::is(ldSketch, "GenotypeHandle")) { stop(sprintf("%s: ldSketch must be a GenotypeHandle.", label)) } @@ -564,8 +569,7 @@ loadLdFromGenotype <- function(genotypePath, region, o <- order(m$idxA) # restore the caller's requested order keptIds <- variantIds[m$idxA[o]] idx <- m$idxB[o] - block <- extractBlockGenotypes(ldSketch, idx, meanImpute = TRUE) - geno <- t(SummarizedExperiment::assay(block, "dosage")) + geno <- .dosageMatrix(ldSketch, idx, meanImpute = TRUE) colnames(geno) <- keptIds ldMat <- computeLd(geno, method = "sample") dimnames(ldMat) <- list(keptIds, keptIds) diff --git a/R/mashPipeline.R b/R/mashPipeline.R index a0646459..93d92a31 100644 --- a/R/mashPipeline.R +++ b/R/mashPipeline.R @@ -100,64 +100,341 @@ mashPipeline <- function(sumStatsList, alpha, set.seed(setSeed) - strongMats <- .mashSumStatsToMatrices(sumStatsList$strong, "strong", - inputScale = inputScale) - randomMats <- if ("random" %in% names(sumStatsList) && - !is.null(sumStatsList$random)) { - .mashSumStatsToMatrices(sumStatsList$random, "random", - inputScale = inputScale) - } else NULL - - hasNull <- "null" %in% names(sumStatsList) && !is.null(sumStatsList$null) - if (hasNull) { + # Vhat: use the supplied residual correlation if given; otherwise derive it + # from the null set (estimate_null_correlation_simple) when a `null` entry is + # present, else fall back to identity. The estimation now lives in exactly one + # place -- mashResidualCorrelation(). `setSeed = NULL` there leaves the RNG + # stream seeded above untouched, so the delegated calls consume it in the same + # order the inline code used to (identity / null-simple consume no RNG before + # cov_flash / cov_ed run downstream). + vhat <- if (!is.null(residualCorrelation)) { + residualCorrelation + } else if ("null" %in% names(sumStatsList) && !is.null(sumStatsList$null)) { + mashResidualCorrelation(sumStatsList, alpha, method = "simple", + inputScale = inputScale, setSeed = NULL) + } else { + mashResidualCorrelation(sumStatsList, alpha, method = "identity", + inputScale = inputScale, setSeed = NULL) + } + + # Prior covariances + mixture weights. mashPriorCovariances() owns the + # cov_canonical / cov_pca / cov_flash / cov_ed chain, the supplied-prior + # bypass, and the mash() weight fit; mashPipeline just forwards its arguments. + prior <- mashPriorCovariances(sumStatsList, alpha, vhat = vhat, + priorCovariances = priorCovariances, + nPcs = nPcs, inputScale = inputScale, + setSeed = NULL) + + list(U = prior$U, w = prior$w) +} + +#' @title Estimate the mash Residual Correlation Matrix (Vhat) +#' @description Estimate the residual (null) correlation matrix \eqn{\hat V} that +#' \code{mashr::mash_set_data()} consumes as \code{V}. Split out of +#' \code{\link{mashPipeline}} so the estimation logic lives in one place and is +#' reusable by the mixture-prior workflows. +#' @param sumStatsList Named list (or \code{S4Vectors::SimpleList}) of +#' \code{\link{QtlSumStats}} / \code{\link{GwasSumStats}}. \code{method = +#' "simple"} needs a \code{"null"} entry; \code{method = "mle"} needs +#' \code{"random"}; \code{method = "identity"} reads only the condition count +#' off \code{"strong"}. +#' @param alpha mash \code{alpha} (forwarded to \code{mashr::mash_set_data()}). +#' @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{"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"}). +#' @param nSubset,maxIter \code{method = "mle"} controls (random-subset size and +#' EM iterations). +#' @param inputScale SumStats -> matrix conversion scale (\code{"auto"} / +#' \code{"beta"} / \code{"z"}). +#' @param setSeed Integer seed, or \code{NULL} to leave the ambient RNG stream +#' untouched (how \code{mashPipeline} keeps one continuous stream across its +#' delegated calls). +#' @return A conditions x conditions residual correlation matrix. +#' @seealso \code{\link{mashPipeline}}, \code{\link{mashPriorCovariances}} +#' @export +mashResidualCorrelation <- function(sumStatsList, alpha, + method = c("simple", "identity", "mle", + "corshrink", "simple_specific"), + priorCovariances = NULL, + nSubset = 6000L, maxIter = 6L, + inputScale = c("auto", "beta", "z"), + setSeed = 999) { + method <- match.arg(method) + inputScale <- match.arg(inputScale) + if (!requireNamespace("mashr", quietly = TRUE)) { + # nocov start + stop("To use this function, please install mashr: ", + "https://cran.r-project.org/web/packages/mashr/index.html") + # nocov end + } + if (methods::is(sumStatsList, "SimpleList")) { + sumStatsList <- as.list(sumStatsList) + } + if (!is.null(setSeed)) set.seed(setSeed) + + if (method == "identity") { + strongMats <- .mashSumStatsToMatrices(sumStatsList$strong, "strong", + inputScale = inputScale) + return(diag(rep(1, ncol(strongMats$b)))) + } + + if (method == "simple") { + if (is.null(sumStatsList$null)) { + stop("mashResidualCorrelation: method 'simple' requires a 'null' entry ", + "in `sumStatsList`.") + } nullMats <- .mashSumStatsToMatrices(sumStatsList$null, "null", - inputScale = inputScale) + inputScale = inputScale) + return(mashr::estimate_null_correlation_simple( + mashr::mash_set_data(nullMats$b, Shat = nullMats$s, + alpha, zero_Bhat_Shat_reset = 1000))) } - if (!hasNull) { - if (!is.null(residualCorrelation)) { - vhat <- residualCorrelation - } else { - # Identity-fallback: count conditions off `strong` so this code - # path works even when random is absent (it always was — and is - # required when residualCorrelation is NULL — but we read off - # strong for symmetry with the priorCovariances dimension check). - conditionNum <- ncol(strongMats$b) - vhat <- diag(rep(1, conditionNum)) + if (method == "mle") { + if (is.null(sumStatsList$random)) { + stop("mashResidualCorrelation: method 'mle' requires a 'random' entry ", + "in `sumStatsList`.") } - } else { - vhat <- mashr::estimate_null_correlation_simple( - mashr::mash_set_data(nullMats$b, - Shat = nullMats$s, - alpha, zero_Bhat_Shat_reset = 1000)) - } - - mashData <- mashr::mash_set_data(strongMats$b, - Shat = strongMats$s, - V = vhat, - alpha, zero_Bhat_Shat_reset = 1000) - - if (is.null(priorCovariances)) { - # Canonical covariance matrices - U.can <- mashr::cov_canonical(mashData) - # PCA-based covariance matrices - if (is.null(nPcs)) { - nPcs <- ncol(mashData$Bhat) - 1 + if (is.null(priorCovariances)) { + stop("mashResidualCorrelation: method 'mle' requires `priorCovariances` ", + "(the prior U the EM refines V against).") } - U.pca <- mashr::cov_pca(mashData, npc = nPcs) - # Flash-based covariance matrices (factor analysis) - U.flash <- mashr::cov_flash(mashData) - # ED-based covariance matrices (initialized from all others) - U.ed <- mashr::cov_ed(mashData, Ulist_init = c(U.can, U.pca, U.flash)) - # Combine all covariance matrices - U.all <- c(U.can, U.pca, U.flash, U.ed) - } else { - # Caller-supplied prior covariance matrices (e.g. pre-baked U from - # a reference dataset). Bypasses cov_canonical / cov_pca / - # cov_flash / cov_ed entirely; mashr only sees the supplied list. + randomMats <- .mashSumStatsToMatrices(sumStatsList$random, "random", + inputScale = inputScale) + n <- nrow(randomMats$b) + idx <- sample(seq_len(n), min(nSubset, n)) + dsub <- mashr::mash_set_data(randomMats$b[idx, , drop = FALSE], + Shat = randomMats$s[idx, , drop = FALSE], + alpha, zero_Bhat_Shat_reset = 1000) + fit <- mashr::mash_estimate_corr_em(dsub, priorCovariances, + max_iter = maxIter, details = TRUE) + return(fit$V) + } + + # method %in% c("corshrink", "simple_specific"): estimate V on the null set. + # In this pipeline the `null` partition is already the null variants + # (mashRandNullSample kept max|z| < 2), so no re-thresholding is needed -- + # the GTEx-specific per-gene `GetSS()` fetch of the legacy notebook is + # replaced by our own null z-matrix. + if (is.null(sumStatsList$null)) { + stop("mashResidualCorrelation: method '", method, "' requires a 'null' ", + "entry in `sumStatsList` (the null variants V is estimated on).") + } + nullMats <- .mashSumStatsToMatrices(sumStatsList$null, "null", + inputScale = inputScale) + # Null z-scores (z-scale: b already = Z, s = 1; beta-scale: b/s = beta/se). + nullZ <- nullMats$b / nullMats$s + + if (method == "simple_specific") { + return(as.matrix(Matrix::nearPD(stats::cov(nullZ), conv.tol = 1e-06, + doSym = TRUE, corr = TRUE)$mat)) + } + + # method == "corshrink": adaptive-shrinkage null correlation (ashr on the + # Fisher-z of the pairwise sample correlations); image = "null" suppresses + # CorShrink's plotting. + if (!requireNamespace("CorShrink", quietly = TRUE)) { + # nocov start (optional-package guard; CorShrink is Suggests-only) + stop("mashResidualCorrelation: method 'corshrink' needs the CorShrink ", + "package. Install it, or use 'simple' / 'simple_specific'.") + # nocov end + } + as.matrix(CorShrink::CorShrinkData( + nullZ, ash.control = list(mixcompdist = "halfuniform"), + image = "null")$cor) +} + +# 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 +# given `components` set reproduces the same ordering everywhere. RNG is consumed +# only by cov_flash / cov_flash(nonneg). Shared by mashPriorCovariances and the +# exported mashCovarianceComponents. +# @noRd +.mashBuildComponents <- function(mashData, components, nPcs = NULL) { + comps <- list() + if ("canonical" %in% components) { + comps <- c(comps, mashr::cov_canonical(mashData)) + } + if ("pca" %in% components) { + if (is.null(nPcs)) nPcs <- ncol(mashData$Bhat) - 1 + comps <- c(comps, mashr::cov_pca(mashData, npc = nPcs)) + } + if ("flash" %in% components) { + comps <- c(comps, mashr::cov_flash(mashData)) + } + if ("flash_nonneg" %in% components) { + comps <- c(comps, mashr::cov_flash(mashData, factors = "nonneg")) + } + comps +} + +#' @title Build mash Data-Driven Covariance Components +#' @description Build the raw per-method data-driven covariance components +#' (\code{cov_canonical} / \code{cov_pca} / \code{cov_flash} / +#' \code{cov_flash(factors = "nonneg")}) for a \code{"strong"} SumStats set -- +#' the reusable building block \code{\link{mashPriorCovariances}} then refines +#' with an ED / udr engine. Exposed on its own so a workflow can build or +#' inspect a single component (the mixture-prior notebook's per-method steps) +#' without running the full prior. +#' @param sumStatsList Named list (or \code{S4Vectors::SimpleList}) with at least +#' \code{"strong"} (the discovery set the covariances are learned on). +#' @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. +#' @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} +#' to leave the ambient RNG untouched. +#' @return A named list of covariance matrices (the concatenated components). +#' @seealso \code{\link{mashPriorCovariances}} +#' @export +mashCovarianceComponents <- function(sumStatsList, alpha, vhat = NULL, + components = c("canonical", "pca", "flash", + "flash_nonneg"), + nPcs = NULL, + inputScale = c("auto", "beta", "z"), + setSeed = 999) { + inputScale <- match.arg(inputScale) + components <- as.character(components) + validComponents <- c("canonical", "pca", "flash", "flash_nonneg") + if (!all(components %in% validComponents)) { + stop("mashCovarianceComponents: unknown component(s): ", + paste(setdiff(components, validComponents), collapse = ", "), + ". Valid: ", paste(validComponents, collapse = ", "), ".") + } + if (!requireNamespace("mashr", quietly = TRUE)) { + # nocov start + stop("To use this function, please install mashr: ", + "https://cran.r-project.org/web/packages/mashr/index.html") + # nocov end + } + if (!requireNamespace("flashier", quietly = TRUE)) { + # nocov start + stop("To use this function, please install flashier: ", + "https://github.com/willwerscheid/flashier") + # nocov end + } + if (methods::is(sumStatsList, "SimpleList")) { + sumStatsList <- as.list(sumStatsList) + } + if (!is.null(setSeed)) set.seed(setSeed) + strongMats <- .mashSumStatsToMatrices(sumStatsList$strong, "strong", + inputScale = inputScale) + if (is.null(vhat)) vhat <- diag(rep(1, ncol(strongMats$b))) + mashData <- mashr::mash_set_data(strongMats$b, Shat = strongMats$s, + V = vhat, alpha, zero_Bhat_Shat_reset = 1000) + .mashBuildComponents(mashData, components = components, nPcs = nPcs) +} + +#' @title Estimate mash Prior Covariances and Mixture Weights +#' @description Build the mash prior covariance list \code{U} and mixture weights +#' \code{w} from a \code{{strong[, random, null]}} SumStats 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 (\code{cov_ed}). +#' @param sumStatsList Named list (or \code{S4Vectors::SimpleList}) with at least +#' \code{"strong"} (the discovery set the covariances are learned on). +#' @param alpha mash \code{alpha}. +#' @param vhat Residual correlation matrix (\code{V}); typically from +#' \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 = +#' "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 +#' exported \code{cov_ed()} extreme deconvolution, whose default +#' \code{algorithm = "bovy"} IS the Bovy et al. 2011 method -- weights from a +#' final \code{mash()}); \code{"ud"} / \code{"ud_ted"} (\pkg{udr} ED / TED +#' updates, returning weights directly -- OPT-IN, known numerical issues, so +#' 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. +#' @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 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 \code{priorCovariances}, which bypasses the engine entirely. +#' @param udControl Named list overriding the \pkg{udr} controls for the +#' \code{"ud"} / \code{"ud_ted"} engines: \code{n_unconstrained} (data-driven +#' matrices to fit; default 50 -- the dominant cost, so reduce it for +#' few-condition data), \code{maxiter} (default 1000), \code{tol}, +#' \code{tol.lik}. Ignored by \code{cov_ed}. +#' @param inputScale SumStats -> matrix conversion scale. +#' @param setSeed Integer seed, or \code{NULL} to leave the ambient RNG untouched. +#' @return \code{list(U, w, loglik)}: the covariance list, the +#' \code{mashr::get_estimated_pi()} mixture weights, and the fit +#' log-likelihood (\code{NULL} for the \code{cov_ed} engine). +#' @seealso \code{\link{mashPipeline}}, \code{\link{mashResidualCorrelation}} +#' @export +mashPriorCovariances <- function(sumStatsList, alpha, vhat = NULL, + components = c("canonical", "pca", "flash", + "flash_nonneg"), + engine = c("cov_ed", "ud", "ud_ted"), + nPcs = NULL, + priorCovariances = NULL, + priorComponents = NULL, + udControl = list(), + inputScale = c("auto", "beta", "z"), + setSeed = 999) { + engine <- match.arg(engine) + inputScale <- match.arg(inputScale) + # udr controls (engine = "ud"/"ud_ted" only). Defaults are the legacy + # mixture-prior values, but `n_unconstrained` dominates the udr cost -- it + # generates that many full data-driven covariances, so 50 (sized for + # many-condition data) massively overparameterises small problems. Reduce it + # for few-condition data. + udControl <- utils::modifyList( + list(n_unconstrained = 50L, maxiter = 1000L, tol = 1e-2, tol.lik = 1e-2), + udControl) + components <- as.character(components) + validComponents <- c("canonical", "pca", "flash", "flash_nonneg") + if (!all(components %in% validComponents)) { + stop("mashPriorCovariances: unknown component(s): ", + paste(setdiff(components, validComponents), collapse = ", "), + ". Valid: ", paste(validComponents, collapse = ", "), ".") + } + if (!requireNamespace("mashr", quietly = TRUE)) { + # nocov start + stop("To use this function, please install mashr: ", + "https://cran.r-project.org/web/packages/mashr/index.html") + # nocov end + } + if (!requireNamespace("flashier", quietly = TRUE)) { + # nocov start + stop("To use this function, please install flashier: ", + "https://github.com/willwerscheid/flashier") + # nocov end + } + if (methods::is(sumStatsList, "SimpleList")) { + sumStatsList <- as.list(sumStatsList) + } + if (!is.null(setSeed)) set.seed(setSeed) + + strongMats <- .mashSumStatsToMatrices(sumStatsList$strong, "strong", + inputScale = inputScale) + if (is.null(vhat)) vhat <- diag(rep(1, ncol(strongMats$b))) + mashData <- mashr::mash_set_data(strongMats$b, Shat = strongMats$s, + V = vhat, alpha, zero_Bhat_Shat_reset = 1000) + + if (!is.null(priorCovariances)) { + # Caller-supplied prior covariance matrices (e.g. pre-baked U from a + # reference dataset). Bypasses the cov_* chain; mashr sees only these. if (!is.list(priorCovariances) || length(priorCovariances) == 0L || is.null(names(priorCovariances)) || any(names(priorCovariances) == "")) { - stop("mashPipeline: `priorCovariances` must be a non-empty named ", + stop("mashPriorCovariances: `priorCovariances` must be a non-empty named ", "list of square covariance matrices.") } nCond <- ncol(mashData$Bhat) @@ -165,25 +442,217 @@ mashPipeline <- function(sumStatsList, alpha, is.matrix(M) && nrow(M) == nCond && ncol(M) == nCond }, logical(1L)) if (any(bad)) { - stop(sprintf(paste0("mashPipeline: every `priorCovariances` entry must be ", - "a %d x %d matrix; offenders: %s."), + stop(sprintf(paste0("mashPriorCovariances: every `priorCovariances` entry ", + "must be a %d x %d matrix; offenders: %s."), nCond, nCond, paste(names(priorCovariances)[bad], collapse = ", "))) } U.all <- priorCovariances - } + w <- NULL + loglik <- NULL + } else { + # Data-driven covariance chain. Use caller-supplied raw components when given + # -- the mixture-prior pipeline, where the per-method component steps built + # them (via mashCovarianceComponents) and this step only refines + weights. + # Otherwise build them here with the same builder mashCovarianceComponents + # surfaces. Either way the chosen engine refines + weights. + if (!is.null(priorComponents)) { + if (!is.list(priorComponents) || length(priorComponents) == 0L || + is.null(names(priorComponents)) || any(names(priorComponents) == "")) { + stop("mashPriorCovariances: `priorComponents` must be a non-empty named ", + "list of covariance matrices (e.g. mashCovarianceComponents() output).") + } + comps <- priorComponents + } else { + comps <- .mashBuildComponents(mashData, components = components, nPcs = nPcs) + } - # Fit mash to estimate mixture weights - m <- mashr::mash(mashData, Ulist = U.all, outputlevel = 1) - w <- mashr::get_estimated_pi(m) + if (engine == "cov_ed") { + # cov_ed() is mashr's exported extreme-deconvolution wrapper; its default + # algorithm = "bovy" IS the internal bovy_wrapper (Bovy et al. 2011), so + # this is the exported route to bovy ED -- no internal reach-in needed. + # It refines the components; mash() (below) then estimates the mixture + # weights over the components + their ED versions (bovy_wrapper's own $pi + # is not needed -- get_estimated_pi over the full set is the proper weight). + U.ed <- mashr::cov_ed(mashData, Ulist_init = comps) + U.all <- c(comps, U.ed) + w <- NULL + loglik <- NULL + } else { + # engine %in% c("ud", "ud_ted") -- udr (OPT-IN; known numerical issues, so + # not the default). udr seeds canonical as its scaled prior and generates + # n_unconstrained data-driven matrices, returning U + w + loglik directly; + # `components` is not used on this path. + if (!requireNamespace("udr", quietly = TRUE)) { + # nocov start (optional-package guard; udr is Suggests-only) + stop("mashPriorCovariances: engine '", engine, "' needs the udr ", + "package. Install it, or use the default 'cov_ed'.") + # nocov end + } + U.can <- mashr::cov_canonical(mashData) + fit0 <- udr::ud_init(mashData, + n_unconstrained = udControl$n_unconstrained, + U_scaled = U.can) + fit <- tryCatch( + udr::ud_fit(fit0, control = list( + unconstrained.update = if (engine == "ud_ted") "ted" else "ed", + scaled.update = "fa", resid.update = "none", + lambda = ncol(mashData$Bhat), penalty.type = "iw", + maxiter = udControl$maxiter, tol = udControl$tol, + tol.lik = udControl$tol.lik), verbose = FALSE), + error = function(e) { + # udr's TED update only supports i.i.d. data (a single shared V). On + # the beta scale each variant carries its own SE, so V differs per + # point and TED errors -- surface a directed message. + if (engine == "ud_ted" && grepl("i.i.d", conditionMessage(e))) { + stop("mashPriorCovariances: engine 'ud_ted' (udr TED update) needs ", + "i.i.d. data (a single shared V), which the beta scale does not ", + "provide (per-variant SE). Use engine 'ud' (ED update), or a ", + "z-scale input.", call. = FALSE) + } + stop(e) + }) + U.all <- lapply(fit$U, function(e) e$mat) + w <- fit$w + loglik <- fit$loglik + } + } - list(U = U.all, w = w) + # cov_ed and the supplied-prior bypass learn weights with a final mash() fit; + # the udr engines already produced them. + if (is.null(w)) { + m <- mashr::mash(mashData, Ulist = U.all, outputlevel = 1) + w <- mashr::get_estimated_pi(m) + } + list(U = U.all, w = w, loglik = loglik) } +# ============================================================================= +# Mash model fit + posterior (mash_fit / mash_posterior notebooks) +# ============================================================================= + +#' @title Fit a mash Model for Posterior Computation +#' @description Fit a \pkg{mashr} model on a chosen partition using a supplied +#' prior covariance list and residual correlation, returning the fitted model. +#' This is the fit step (\code{mash_fit}'s first step): following Urbut et al. +#' 2019 the mixture weights are learned on the representative \code{"random"} +#' partition, and the resulting model is then applied to the strong / target +#' set by \code{\link{mashPosterior}}. +#' @param sumStatsList Named list (or \code{S4Vectors::SimpleList}) of +#' \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 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"}. +#' @param outputLevel \code{mashr::mash()} \code{outputlevel} (default 4 -- the +#' full model \code{\link{mashPosterior}} consumes). +#' @param inputScale SumStats -> matrix conversion scale. +#' @param setSeed Integer seed, or \code{NULL} to leave the ambient RNG untouched. +#' @return The fitted \pkg{mashr} model (the \code{mashr::mash()} object). +#' @seealso \code{\link{mashPosterior}}, \code{\link{mashPriorCovariances}} +#' @export +mashModelFit <- function(sumStatsList, alpha, priorCovariances, vhat = NULL, + fitOn = c("random", "strong"), outputLevel = 4L, + inputScale = c("auto", "beta", "z"), setSeed = 999) { + fitOn <- match.arg(fitOn) + inputScale <- match.arg(inputScale) + if (!requireNamespace("mashr", quietly = TRUE)) { + # nocov start + stop("To use this function, please install mashr: ", + "https://cran.r-project.org/web/packages/mashr/index.html") + # nocov end + } + if (methods::is(sumStatsList, "SimpleList")) { + sumStatsList <- as.list(sumStatsList) + } + if (is.null(priorCovariances) || !is.list(priorCovariances) || + length(priorCovariances) == 0L || is.null(names(priorCovariances))) { + stop("mashModelFit: `priorCovariances` must be a non-empty named list of ", + "covariance matrices (e.g. mashPriorCovariances()$U).") + } + if (is.null(sumStatsList[[fitOn]])) { + stop("mashModelFit: `sumStatsList` has no '", fitOn, "' entry to fit on.") + } + if (!is.null(setSeed)) set.seed(setSeed) + mats <- .mashSumStatsToMatrices(sumStatsList[[fitOn]], fitOn, + inputScale = inputScale) + if (is.null(vhat)) vhat <- diag(rep(1, ncol(mats$b))) + mashData <- mashr::mash_set_data(mats$b, Shat = mats$s, V = vhat, alpha, + zero_Bhat_Shat_reset = 1000) + mashr::mash(mashData, Ulist = priorCovariances, outputlevel = outputLevel) +} + +#' @title Compute mash Posterior Matrices for a Target Set +#' @description Apply a fitted \pkg{mashr} model (from \code{\link{mashModelFit}}) +#' to a target SumStats set, returning the posterior matrices +#' (\code{PosteriorMean}, \code{PosteriorSD}, \code{lfsr}, ...). This is the +#' posterior step of the mash workflow -- \code{mash_fit}'s second step and +#' \code{mash_posterior}'s per-analysis-unit computation. +#' @param model A fitted \pkg{mashr} model (the \code{\link{mashModelFit}} +#' output). +#' @param sumStats A single \code{\link{QtlSumStats}} / \code{\link{GwasSumStats}} +#' -- the target (e.g. strong) set to compute posteriors on. +#' @param alpha mash \code{alpha} (match the fit). +#' @param vhat Residual correlation matrix (\code{V}); \code{NULL} -> identity. +#' @param excludeCondition Character vector of condition (column) names to drop +#' from the target AND the model before computing posteriors (the model's +#' covariances are resized via \code{\link{updateMashModelCov}}). Default none. +#' @param outputPosteriorCov Return the full posterior covariance array (needed +#' by \code{\link{fitMashContrast}}). Default \code{TRUE}. +#' @param inputScale SumStats -> matrix conversion scale. +#' @return The \code{mashr::mash_compute_posterior_matrices()} result: a list of +#' \code{PosteriorMean} / \code{PosteriorSD} / \code{lfsr} / \code{NegativeProb} +#' (+ \code{PosteriorCov} when \code{outputPosteriorCov = TRUE}). +#' @seealso \code{\link{mashModelFit}}, \code{\link{fitMashContrast}} +#' @export +mashPosterior <- function(model, sumStats, alpha, vhat = NULL, + excludeCondition = character(0), + outputPosteriorCov = TRUE, + inputScale = c("auto", "beta", "z")) { + inputScale <- match.arg(inputScale) + if (!requireNamespace("mashr", quietly = TRUE)) { + # nocov start + stop("To use this function, please install mashr: ", + "https://cran.r-project.org/web/packages/mashr/index.html") + # nocov end + } + mats <- .mashSumStatsToMatrices(sumStats, "target", inputScale = inputScale) + b <- mats$b + s <- mats$s + allConditions <- colnames(b) + excludeCondition <- as.character(excludeCondition) + if (length(excludeCondition) > 0L) { + bad <- setdiff(excludeCondition, allConditions) + if (length(bad) > 0L) { + stop("mashPosterior: excludeCondition not found in the target: ", + paste(bad, collapse = ", "), ".") + } + keep <- setdiff(allConditions, excludeCondition) + if (length(keep) == 0L) { + stop("mashPosterior: excludeCondition drops every condition.") + } + # Index positionally: b/s carry condition colnames, but a supplied `vhat` + # (e.g. diag(K)) may have no dimnames, so a name subscript would error. + keepIdx <- match(keep, allConditions) + b <- b[, keepIdx, drop = FALSE] + s <- s[, keepIdx, drop = FALSE] + if (!is.null(vhat)) vhat <- vhat[keepIdx, keepIdx, drop = FALSE] + model <- updateMashModelCov(model, allConditions, keep) + } + if (is.null(vhat)) vhat <- diag(rep(1, ncol(b))) + mashData <- mashr::mash_set_data(b, Shat = s, V = vhat, alpha, + zero_Bhat_Shat_reset = 1000) + mashr::mash_compute_posterior_matrices( + model, mashData, output_posterior_cov = outputPosteriorCov) +} + # ============================================================================= # Mash pairwise contrast functions # ============================================================================= @@ -319,6 +788,55 @@ fitMashContrast <- function(index, origMean, posteriorMean, posteriorVcov, df } +#' Posterior contrast table over an entire mash posterior +#' +#' Orchestrates \code{\link{fitMashContrast}} across every feature (variant) +#' of a mash posterior: aligns the original effect matrix to the posterior +#' columns, runs the per-feature deviation + pairwise contrast, row-binds the +#' results (aligning the union of contrast columns), and orders them +#' (\code{mean}/\code{se}/\code{p}, deviation before pairwise). Features with +#' fewer than two tested conditions are dropped. +#' +#' @param posteriorMean Numeric matrix (features x conditions) of posterior +#' means (\code{PosteriorMean} from \code{\link{mashPosterior}}). +#' @param posteriorVcov Numeric array (conditions x conditions x features) of +#' posterior covariances (\code{PosteriorCov}). +#' @param origMean Numeric matrix (features x conditions) of the original +#' effect estimates (e.g. \code{bhat}); used to decide which conditions were +#' tested per feature. Aligned to \code{posteriorMean}'s columns by name; +#' \code{NaN} is treated as 0 (untested). +#' @param grouping Optional named integer vector assigning conditions to groups +#' (0 = independent); forwarded to \code{\link{fitMashContrast}} so replicate +#' populations of one cell type share weight. Names are condition labels. +#' @return A \code{data.frame} (features x contrasts) with +#' \code{mean_contrast_*}, \code{se_contrast_*}, \code{p_contrast_*} columns +#' and feature ids as row names. Empty when nothing is testable. +#' @seealso \code{\link{fitMashContrast}}, \code{\link{metaAnalysisPerCondition}} +#' @importFrom dplyr bind_rows select matches +#' @export +mashPosteriorContrast <- function(posteriorMean, posteriorVcov, origMean, + grouping = NULL) { + origMean <- origMean[, colnames(posteriorMean), drop = FALSE] + origMean[is.nan(origMean)] <- 0 + + parts <- lapply(seq_len(nrow(posteriorMean)), function(i) + fitMashContrast(i, origMean, posteriorMean, posteriorVcov, + grouping = grouping)) + parts <- parts[!vapply(parts, is.null, logical(1))] + if (length(parts) == 0L) return(data.frame()) + + # fitMashContrast sets each 1-row frame's rowname to the feature id, but + # bind_rows drops row names -- capture them first, restore after. + featureIds <- unlist(lapply(parts, rownames), use.names = FALSE) + res <- as.data.frame(dplyr::bind_rows(parts)) + res <- dplyr::select(res, + dplyr::matches("mean_contrast.*deviation"), dplyr::matches("mean_contrast.*_vs_"), + dplyr::matches("se_contrast.*deviation"), dplyr::matches("se_contrast.*_vs_"), + dplyr::matches("p_contrast.*deviation"), dplyr::matches("p_contrast.*_vs_")) + rownames(res) <- featureIds + res +} + # ============================================================================= # Mash model subsetting functions # ============================================================================= @@ -415,25 +933,31 @@ sanitizeMashData <- function(data) { data } -#' Random-Effects Meta-Analysis of Mash Pairwise Contrasts +#' Random-Effects Meta-Analysis of Mash Pairwise Contrasts, per Condition #' -#' For each cell type (condition), gathers all pairwise contrast effect -#' sizes and standard errors involving that cell, then runs a -#' DerSimonian–Laird random-effects meta-analysis per condition. -#' Intended to be run on the output of \code{\link{fitMashContrast}}. +#' For each condition (context), gathers all pairwise contrast effect sizes and +#' standard errors involving that condition, then runs a random-effects +#' meta-analysis (via \code{metafor::rma}; pecotmr does not implement its own +#' meta-analysis). Intended to be run on the output of +#' \code{\link{fitMashContrast}} / \code{\link{mashPosteriorContrast}}. #' -#' @param effectSizes Numeric matrix (features x conditions) of contrast +#' @param effectSizes Numeric matrix (features x contrasts) of contrast #' effect sizes. Column names must follow the pattern -#' \code{mean_contrast__vs_}. -#' @param seValues Numeric matrix (features x conditions) of contrast +#' \code{mean_contrast__vs_}. +#' @param seValues Numeric matrix (features x contrasts) of contrast #' standard errors. Must have the same dimensions and column names as #' \code{effectSizes}. -#' @param seCutoff Numeric; minimum SE below which a condition is excluded +#' @param seCutoff Numeric; minimum SE below which a contrast is excluded #' from the meta-analysis for a given feature (default 0). +#' @param metaMethod Between-study variance estimator for the random-effects +#' meta-analysis, forwarded to \code{metafor::rma(method = )}. Default +#' \code{"DL"} (DerSimonian-Laird); other options include \code{"REML"}, +#' \code{"ML"}, \code{"EB"}. #' @return A tibble with columns: #' \describe{ -#' \item{cell}{Cell type name.} -#' \item{condition}{Original pairwise contrast name (without prefix).} +#' \item{condition}{The condition (context) name.} +#' \item{contrast}{Pairwise contrast name (without prefix), e.g. +#' \code{conditionA_vs_conditionB}.} #' \item{meta_pvalue}{P-value from the random-effects meta-analysis.} #' \item{meta_effect}{Pooled absolute effect size estimate.} #' \item{meta_se}{Standard error of the pooled estimate.} @@ -444,28 +968,28 @@ sanitizeMashData <- function(data) { #' @importFrom tibble tibble #' @importFrom dplyr bind_rows #' @export -metaAnalysisPerCell <- function(effectSizes, seValues, - seCutoff = 0) { +metaAnalysisPerCondition <- function(effectSizes, seValues, + seCutoff = 0, metaMethod = "DL") { stopifnot(identical(dim(effectSizes), dim(seValues))) stopifnot(identical(colnames(effectSizes), colnames(seValues))) - conditions <- sub("^mean_contrast_", "", colnames(effectSizes)) - cells <- unique(c(sub("_vs_.*", "", conditions), - sub(".*_vs_", "", conditions))) + contrasts <- sub("^mean_contrast_", "", colnames(effectSizes)) + conditions <- unique(c(sub("_vs_.*", "", contrasts), + sub(".*_vs_", "", contrasts))) results <- list() - for (cell in cells) { - # Columns involving this cell - cellIdx <- grep(cell, colnames(effectSizes)) - if (length(cellIdx) == 0) next + for (condition in conditions) { + # Contrast columns involving this condition + idx <- grep(condition, colnames(effectSizes)) + if (length(idx) == 0) next - cellEffects <- effectSizes[, cellIdx, drop = FALSE] - cellSes <- seValues[, cellIdx, drop = FALSE] - cellConditions <- conditions[cellIdx] + condEffects <- effectSizes[, idx, drop = FALSE] + condSes <- seValues[, idx, drop = FALSE] + condContrasts <- contrasts[idx] - for (i in seq_along(cellConditions)) { - es <- abs(as.numeric(cellEffects[, i])) - se <- as.numeric(cellSes[, i]) + for (i in seq_along(condContrasts)) { + es <- abs(as.numeric(condEffects[, i])) + se <- as.numeric(condSes[, i]) # Filter by SE cutoff keep <- se > seCutoff & is.finite(es) & is.finite(se) @@ -474,8 +998,8 @@ metaAnalysisPerCell <- function(effectSizes, seValues, if (length(es) < 2) { results[[length(results) + 1]] <- tibble( - cell = cell, - condition = cellConditions[i], + condition = condition, + contrast = condContrasts[i], meta_pvalue = if (length(es) == 1) { .zToPvalue(es / se) } else NA_real_, @@ -487,11 +1011,11 @@ metaAnalysisPerCell <- function(effectSizes, seValues, next } - ma <- metaRandomEffects(es, se) + ma <- .rmaMeta(es, se, method = metaMethod) z <- ma$mean / ma$se results[[length(results) + 1]] <- tibble( - cell = cell, - condition = cellConditions[i], + condition = condition, + contrast = condContrasts[i], meta_pvalue = .zToPvalue(z), meta_effect = ma$mean, meta_se = ma$se, @@ -503,3 +1027,114 @@ metaAnalysisPerCell <- function(effectSizes, seValues, bind_rows(results) } + +#' Feature score from deviation contrasts (random-effects meta per condition) +#' +#' For each condition's deviation contrast, meta-analyzes the per-variant +#' absolute effect sizes (random-effects, via \code{metafor::rma}) and returns +#' the pooled Z-score (\eqn{\hat\mu / \mathrm{se}}). One score per condition -- +#' the "meta" feature score of \code{mash_posterior.ipynb}. +#' +#' @param contrastResult A contrast table from \code{\link{mashPosteriorContrast}} +#' (variants x contrasts) carrying \code{mean_contrast_*_deviation} and +#' \code{se_contrast_*_deviation} columns. +#' @param metaMethod Between-study variance estimator forwarded to +#' \code{metafor::rma} (default \code{"REML"}). +#' @return A \code{data.frame} with \code{condition} and \code{zScore}. +#' @seealso \code{\link{nSignificantScore}}, \code{\link{scoreFromCs}} +#' @export +calculateFeatureScores <- function(contrastResult, metaMethod = "REML") { + cr <- as.data.frame(contrastResult, stringsAsFactors = FALSE) + effCols <- grep("mean_contrast_.*deviation", names(cr), value = TRUE) + if (length(effCols) == 0L) + return(data.frame(condition = character(0), zScore = numeric(0), + stringsAsFactors = FALSE)) + scores <- vapply(effCols, function(ec) { + seCol <- sub("^mean_contrast", "se_contrast", ec) + if (!seCol %in% names(cr)) return(NA_real_) + es <- abs(as.numeric(cr[[ec]])) + se <- as.numeric(cr[[seCol]]) + keep <- is.finite(es) & is.finite(se) & se > 0 + es <- es[keep]; se <- se[keep] + if (length(es) < 1L) return(NA_real_) + ma <- .rmaMeta(es, se, method = metaMethod) + ma$mean / ma$se + }, numeric(1)) + data.frame( + condition = sub("_deviation$", "", sub("^mean_contrast_", "", effCols)), + zScore = as.numeric(scores), stringsAsFactors = FALSE) +} + +#' Feature score from the fraction of significant deviation contrasts +#' +#' For each condition's deviation contrast, the proportion of variants whose +#' contrast p-value falls below \code{pCutoff} -- the "n-significant" feature +#' score of \code{mash_posterior.ipynb}. No meta-analysis is involved. +#' +#' @param contrastResult A contrast table from \code{\link{mashPosteriorContrast}} +#' carrying \code{p_contrast_*_deviation} columns. +#' @param pCutoff Significance threshold (default 1e-5). +#' @return A \code{data.frame} with \code{condition} and \code{ratio} +#' (\eqn{n_{sig} / n}). +#' @export +nSignificantScore <- function(contrastResult, pCutoff = 1e-5) { + cr <- as.data.frame(contrastResult, stringsAsFactors = FALSE) + pCols <- grep("p_contrast_.*deviation", names(cr), value = TRUE) + if (length(pCols) == 0L) + return(data.frame(condition = character(0), ratio = numeric(0), + stringsAsFactors = FALSE)) + ratios <- vapply(pCols, function(pc) { + p <- as.numeric(cr[[pc]]) + nTot <- sum(!is.na(p)) + if (nTot == 0L) NA_real_ else sum(p < pCutoff, na.rm = TRUE) / nTot + }, numeric(1)) + data.frame( + condition = sub("_deviation$", "", sub("^p_contrast_", "", pCols)), + ratio = as.numeric(ratios), stringsAsFactors = FALSE) +} + +#' Feature score from fine-mapped credible sets +#' +#' Scores a condition using a fine-mapping table: takes the lead (max-PIP) +#' variant of each credible set, intersects with the contrast variants, picks +#' the least-significant lead by deviation p-value, and returns the maximum +#' pairwise \eqn{|\mathrm{mean}| / \mathrm{se}} at that variant -- the "finemap" +#' feature score of \code{mash_posterior.ipynb}. +#' +#' @param fineMapping A fine-mapping \code{data.frame} with \code{cs_order}, +#' \code{pip} and \code{variants} columns (credible-set index 0 = not in a CS). +#' @param contrastResults A contrast table from +#' \code{\link{mashPosteriorContrast}} with variant row names. +#' @param condition Condition label whose deviation p-value column is used; if +#' that column is absent and exactly one pairwise contrast exists, the +#' pairwise p-value is used instead. +#' @return A single numeric score, or \code{NA} when nothing overlaps. +#' @export +scoreFromCs <- function(fineMapping, contrastResults, condition) { + css <- setdiff(unique(fineMapping$cs_order), 0) + if (length(css) == 0L) return(NA_real_) + leadRows <- do.call(rbind, lapply(css, function(cs) { + tmp <- fineMapping[fineMapping$cs_order == cs, , drop = FALSE] + tmp[tmp$pip == max(tmp$pip), , drop = FALSE] + })) + cr <- as.data.frame(contrastResults, stringsAsFactors = FALSE) + snps <- intersect(rownames(cr), leadRows$variants) + if (length(snps) == 0L) return(NA_real_) + + pDevCol <- grep(paste0("p_contrast_", condition, "_deviation"), + names(cr), value = TRUE) + if (length(pDevCol) > 0L) { + contrastP <- cr[snps, pDevCol[1L], drop = FALSE] + } else { + pvCols <- grep("p_contrast.*_vs_", names(cr), value = TRUE) + if (length(pvCols) != 1L) return(NA_real_) + contrastP <- cr[snps, pvCols, drop = FALSE] + } + maxSnp <- rownames(contrastP)[which(contrastP[, 1L] == + max(contrastP[, 1L], na.rm = TRUE))] + meanVs <- as.numeric(as.matrix(cr[maxSnp, + grep("mean_contrast.*_vs_", names(cr)), drop = FALSE])) + seVs <- as.numeric(as.matrix(cr[maxSnp, + grep("se_contrast.*_vs_", names(cr)), drop = FALSE])) + max(abs(meanVs / seVs), na.rm = TRUE) +} diff --git a/R/mashWrapper.R b/R/mashWrapper.R index 52bae2a2..30bc29c5 100644 --- a/R/mashWrapper.R +++ b/R/mashWrapper.R @@ -232,6 +232,256 @@ mergeMashData <- function(resData, oneData) { return(combinedData) } +# Build variants x conditions (Bhat, Shat) matrices for ONE object plus the +# row indices of its "strong" variants. Class dispatch: +# QtlSumStats / GwasSumStats -> .mashSumStatsToMatrices; strong = the single +# most significant variant (max|z|) per condition, unioned. +# FineMappingResultBase -> pivot getMarginalEffects() into a +# variants x context (beta, se) pair; strong = the lead (max PIP) variant +# of each credible set in each condition (getCs()), unioned. Conditions +# with no credible set contribute no strong variant. +# For z-scale QtlSumStats the returned Shat is 1, so downstream code that forms +# z = b / s recovers the z-scores uniformly across both scales. +# @noRd +.mashObjectMatrices <- function(obj, inputScale, coverage) { + if (methods::is(obj, "QtlSumStats") || methods::is(obj, "GwasSumStats")) { + mats <- .mashSumStatsToMatrices(obj, "mash input", inputScale = inputScale) + z <- mats$b / mats$s + # most significant variant (max|z|) per condition column, unioned + strongRows <- sort(unique(apply(abs(z), 2L, which.max))) + return(list(b = mats$b, s = mats$s, strongRows = strongRows)) + } + if (methods::is(obj, "FineMappingResultBase")) { + me <- getMarginalEffects(obj) + cs <- getCs(obj, coverage = coverage) + if (!all(c("variant_id", "context", "beta", "se") %in% names(me))) { + stop("mashInput: getMarginalEffects() must return variant_id/context/", + "beta/se columns; a FineMappingResult with >= 2 contexts is required.") + } + # A multi-method result would duplicate (variant, context) cells; pin the + # first method so the pivot is unambiguous. + if ("method" %in% names(me) && length(unique(me$method)) > 1L) { + m1 <- me$method[[1L]] + warning("mashInput: FineMappingResult carries multiple methods; ", + "using '", m1, "'.") + me <- me[me$method == m1, , drop = FALSE] + if ("method" %in% names(cs)) cs <- cs[cs$method == m1, , drop = FALSE] + } + contexts <- unique(me$context) + variants <- unique(me$variant_id) + b <- matrix(NA_real_, length(variants), length(contexts), + dimnames = list(variants, contexts)) + s <- b + cell <- cbind(match(me$variant_id, variants), match(me$context, contexts)) + b[cell] <- me$beta + s[cell] <- me$se + # strong = lead (max PIP) variant of each credible set in each condition + strongVar <- character(0) + csCol <- grep("^cs_", names(cs), value = TRUE) + if (nrow(cs) > 0L && length(csCol) > 0L && "pip" %in% names(cs)) { + grp <- interaction(cs$context, cs[[csCol[[1L]]]], drop = TRUE) + for (rows in split(seq_len(nrow(cs)), grp)) { + strongVar <- c(strongVar, cs$variant_id[[rows[[which.max(cs$pip[rows])]]]]) + } + } + strongRows <- sort(match(unique(strongVar), variants)) + return(list(b = b, s = s, strongRows = strongRows[!is.na(strongRows)])) + } + stop("mashInput: each element of `objects` must be a QtlSumStats, ", + "GwasSumStats, or FineMappingResult; got ", + paste(class(obj), collapse = "/"), ".") +} + +# Extract the strong / random / null partitions from ONE object as a flat +# list(strong.b, strong.s, random.b, random.s, null.b, null.s) of +# variants x conditions matrices. Random / null are drawn by the shared +# mashRandNullSample() over the object's (Bhat, Shat); strong is the +# deterministic class-specific selection from .mashObjectMatrices(). +# @noRd +.mashObjectPartitions <- function(obj, nRandom, nNull, excludeCondition, + coverage, inputScale, seed, + independentVariants = NULL) { + mats <- .mashObjectMatrices(obj, inputScale = inputScale, coverage = coverage) + keepCols <- setdiff(colnames(mats$b), excludeCondition) + if (length(keepCols) < 2L) { + stop("mashInput: fewer than 2 conditions remain for an object (after ", + "excludeCondition); mash operates across conditions and needs >= 2.") + } + + # Random / null candidate pool: optionally restrict to LD-independent variants + # so the background carries no LD-correlated SNPs (which would bias Vhat and + # the mixture weights). Matching is delegated to matchVariants() -- proper + # chrom/pos/allele matching (ref/alt flips OK, no strand flip), NOT a raw + # string compare. Strong is ALWAYS drawn from the full set (every top signal + # is kept regardless of LD pruning). + poolB <- mats$b; poolS <- mats$s + if (!is.null(independentVariants) && length(independentVariants) > 0L) { + # QtlSumStats matrix rownames carry a "study::trait::" block prefix; strip + # it to the bare variant id before matching. + rawIds <- sub(".*::", "", rownames(mats$b)) + keepIdx <- matchVariants(rawIds, independentVariants, allowFlip = TRUE, + removeStrandAmbiguous = FALSE)$idxA + if (length(keepIdx) == 0L) { + warning("mashInput: no variants matched the independent-variant list; ", + "the random/null background is empty for this object.") + } + poolB <- mats$b[keepIdx, , drop = FALSE] + poolS <- mats$s[keepIdx, , drop = FALSE] + } + + rn <- mashRandNullSample(list(bhat = poolB, sbhat = poolS), + nRandom = nRandom, nNull = nNull, + excludeCondition = excludeCondition, seed = seed) + out <- list() + if (length(mats$strongRows) > 0L) { + out[["strong.b"]] <- mats$b[mats$strongRows, keepCols, drop = FALSE] + out[["strong.s"]] <- mats$s[mats$strongRows, keepCols, drop = FALSE] + } + if (!is.null(rn$random) && length(rn$random) > 0L) { + out[["random.b"]] <- rn$random$bhat + out[["random.s"]] <- rn$random$sbhat + } + if (!is.null(rn$null) && length(rn$null) > 0L) { + out[["null.b"]] <- rn$null$bhat + out[["null.s"]] <- rn$null$sbhat + } + out +} + +#' Assemble MASH strong / random / null input from S4 objects +#' +#' Unified, S4-native replacement for the legacy +#' \code{load_multitrait_*_sumstat} + \code{mash_ran_null_sample} assembly. +#' Consumes a list of already-constructed objects (one per region) and returns +#' the flat \code{variants x conditions} matrix list consumed by the MASH +#' mixture-prior / fit / posterior steps. +#' +#' For EACH object three partitions are extracted: +#' \describe{ +#' \item{strong}{The high-signal variants (deterministic, class-specific). +#' \code{QtlSumStats}: the single most significant variant (\eqn{\max|z|}) +#' per condition, unioned. \code{FineMappingResult}: the lead variant +#' (\eqn{\max} PIP) of each credible set in each condition, unioned +#' (conditions with no credible set contribute nothing).} +#' \item{random}{\code{nRandom} variants sampled uniformly at random -- +#' represents the genome-wide mixture of effects and drives the mixture +#' weights.} +#' \item{null}{\code{nNull} variants sampled from those with \eqn{\max|z|<2} +#' -- the noise floor used to estimate the residual correlation (Vhat).} +#' } +#' Random and null are selected identically for both classes +#' (\code{\link{mashRandNullSample}} over the object's \code{Bhat}/\code{Shat}). +#' Partitions are merged across objects (rownames disambiguated by region name), +#' cleaned + z-derived by \code{\link{filterInvalidSummaryStat}} (\code{btoz}), +#' and the strong \code{XtX} cross-product appended. +#' +#' @param objects A named \code{list} of \code{\link{QtlSumStats}} and/or +#' \code{\link{FineMappingResult}} objects, one per region. Names disambiguate +#' rownames across regions (defaults to \code{region1}, \code{region2}, ...). +#' For \code{QtlSumStats} inputs \code{\link{summaryStatsQc}} must have been +#' run (the matrix builder rejects un-QC'd SumStats). +#' @param nRandom,nNull Per-object random / null sample sizes (default 10 each). +#' @param excludeCondition Character vector of condition (column) names to drop. +#' @param coverage Credible-set coverage for \code{FineMappingResult} strong +#' selection (default 0.95). +#' @param zOnly When \code{TRUE} the returned partitions carry only \code{.z} +#' (the \code{.b}/\code{.s} matrices are dropped after z is derived). +#' @param sigPCutoff Significance cutoff applied to the strong partition +#' (default 1e-6). +#' @param inputScale Matrix scale for \code{QtlSumStats} inputs +#' (\code{"auto"}/\code{"beta"}/\code{"z"}); ignored for \code{FineMappingResult} +#' (always effect-size scale). +#' @param independentVariants Optional character vector of variant ids (e.g. an +#' LD-pruned independent SNP list). When supplied, the \emph{random} and +#' \emph{null} background of every object is restricted to variants that match +#' this set, so the background carries no LD-correlated SNPs (which would bias +#' the residual correlation and the mixture weights). Matching is delegated to +#' \code{matchVariants()} (chrom/pos/allele aware, ref/alt flips tolerated), +#' \emph{not} a raw string compare, so a chr-prefix / separator / allele-order +#' difference still matches. The \emph{strong} partition is never filtered. +#' @param seed RNG seed for the random / null sampling (default 999). +#' +#' @return A flat \code{list}: \code{strong.b}, \code{strong.s}, \code{strong.z}, +#' \code{random.*}, \code{null.*} (each a \code{variants x conditions} matrix) +#' and \code{XtX} (a \code{conditions x conditions} matrix). The \code{.b} / +#' \code{.s} matrices are omitted when \code{zOnly = TRUE}. +#' @seealso \code{\link{mashRandNullSample}}, \code{\link{mergeMashData}}, +#' \code{\link{filterInvalidSummaryStat}} +#' @export +mashInput <- function(objects, nRandom = 10L, nNull = 10L, + excludeCondition = character(0), coverage = 0.95, + zOnly = FALSE, sigPCutoff = 1e-6, + inputScale = c("auto", "beta", "z"), + independentVariants = NULL, seed = 999L) { + inputScale <- match.arg(inputScale) + if (!is.null(independentVariants)) { + independentVariants <- as.character(independentVariants) + } + if (!is.list(objects) || length(objects) == 0L) { + stop("mashInput: `objects` must be a non-empty list of QtlSumStats ", + "and/or FineMappingResult objects.") + } + if (is.null(names(objects)) || any(!nzchar(names(objects)))) { + names(objects) <- paste0("region", seq_along(objects)) + } + + combined <- list() + for (nm in names(objects)) { + part <- .mashObjectPartitions(objects[[nm]], nRandom = nRandom, + nNull = nNull, + excludeCondition = excludeCondition, + coverage = coverage, inputScale = inputScale, + seed = seed, + independentVariants = independentVariants) + # Disambiguate rownames across regions before accumulating. + part <- lapply(part, function(m) { + if (!is.null(m) && nrow(m) > 0L) { + rownames(m) <- paste(rownames(m), nm, sep = "_") + } + m + }) + combined <- mergeMashData(combined, part) + } + + # A single-object run leaves matrices; coerce to data.frame so the + # dplyr-based filterInvalidSummaryStat accepts every partition uniformly. + combined <- lapply(combined, function(m) { + if (is.null(m)) return(NULL) # nocov (partitions are always matrices here, never NULL) + as.data.frame(m) + }) + + # Clean each partition and derive z = b / s. Order random/null before strong + # so the strong significance filter (keyed on strong.z) runs exactly once. + for (cond in c("random", "null", "strong")) { + bKey <- paste0(cond, ".b"); sKey <- paste0(cond, ".s") + if (!is.null(combined[[bKey]]) && !is.null(combined[[sKey]])) { + combined <- filterInvalidSummaryStat(combined, bhat = bKey, sbhat = sKey, + btoz = TRUE, sigPCutoff = sigPCutoff) + } + } + + # filterInvalidSummaryStat subsets the strong partition without drop = FALSE, + # so a single surviving strong variant degrades to a vector; restore the + # 1-row matrix shape (conditions preserved as column names). + for (k in c("strong.b", "strong.s", "strong.z")) { + v <- combined[[k]] + if (!is.null(v) && is.null(dim(v))) { + combined[[k]] <- matrix(v, nrow = 1L, dimnames = list(NULL, names(v))) + } + } + + # Strong XtX cross-product (conditions x conditions). + if (!is.null(combined$strong.z) && nrow(as.matrix(combined$strong.z)) > 0L) { + sz <- as.matrix(combined$strong.z) + combined$XtX <- crossprod(sz) / nrow(sz) + } + + if (zOnly) { + combined[grep("\\.(b|s)$", names(combined), value = TRUE)] <- NULL + } + combined +} + #' @title Build a QtlSumStats from a Z-score matrix #' @description Assemble a per-condition \code{\link{QtlSumStats}} from a #' \code{variants x conditions} Z-score matrix -- the input shape the mash @@ -249,7 +499,9 @@ mergeMashData <- function(resData, oneData) { #' variant ids (ideally \code{chr:pos:A2:A1}); \code{colnames(z)} label the #' conditions. #' @param study Study identifier (recycled across conditions). -#' @param ldSketch A \code{\link{GenotypeHandle}} embedded in the collection. +#' @param ldSketch A \code{\link{GenotypeHandle}} embedded in the collection, or +#' \code{NULL} (default) -- mash operates across conditions per variant and +#' needs no LD reference. #' @param context Condition context label(s): a single value recycled across #' every column, or a length-\code{ncol(z)} vector (one per condition). #' Defaults to \code{colnames(z)} -- one context per column. @@ -265,18 +517,88 @@ mergeMashData <- function(resData, oneData) { #' @importFrom GenomicRanges GRanges #' @importFrom IRanges IRanges #' @export -qtlSumStatsFromZMatrix <- function(z, study, ldSketch, +qtlSumStatsFromZMatrix <- function(z, study, ldSketch = NULL, context = colnames(z), trait = "mash", genome = "GRCh38", n = 1000L, a1 = "A", a2 = "G", role = "mash") { if (!is.matrix(z) || !is.numeric(z)) { stop("qtlSumStatsFromZMatrix: `z` must be a numeric variants x conditions matrix.") } - nCond <- ncol(z) - context <- .qszmRecycle(context, nCond, "context") - trait <- .qszmRecycle(trait, nCond, "trait") vids <- rownames(z) if (is.null(vids)) vids <- paste0("var", seq_len(nrow(z))) + .qtlSumStatsFromMatrix( + vids = vids, nCond = ncol(z), study = study, ldSketch = ldSketch, + context = context, trait = trait, genome = genome, role = role, + mcolFn = function(j) S4Vectors::DataFrame( + SNP = vids, A1 = rep(a1, length(vids)), A2 = rep(a2, length(vids)), + Z = as.numeric(z[, j]), N = rep(as.integer(n), length(vids)))) +} + +#' @title Build a QtlSumStats from Bhat / Shat (effect-size) Matrices +#' @description Assemble a per-condition \code{\link{QtlSumStats}} from an aligned +#' pair of \code{variants x conditions} effect-size (\code{Bhat}) and +#' standard-error (\code{Shat}) matrices -- the beta-scale (EE) counterpart of +#' \code{\link{qtlSumStatsFromZMatrix}}. Each entry carries \code{BETA}, +#' \code{SE}, and (derived) \code{Z = BETA / SE} mcols, so the result feeds +#' \code{\link{mashPipeline}} / \code{\link{mashModelFit}} on either scale +#' (\code{inputScale = "beta"} or \code{"z"}). Chromosome / position are decoded +#' from the row (variant) ids exactly as in \code{\link{qtlSumStatsFromZMatrix}}. +#' @param bhat Numeric matrix (variants x conditions) of effect sizes. +#' \code{rownames(bhat)} are variant ids; \code{colnames(bhat)} label the +#' conditions. +#' @param shat Numeric matrix of standard errors, aligned with \code{bhat} +#' (identical dimensions and row/column order). +#' @param study Study identifier (recycled across conditions). +#' @param ldSketch A \code{\link{GenotypeHandle}} embedded in the collection, or +#' \code{NULL} (default) -- mash operates across conditions per variant and +#' needs no LD reference. +#' @param context,trait Condition labels; see \code{\link{qtlSumStatsFromZMatrix}}. +#' Defaults \code{context = colnames(bhat)}, \code{trait = "mash"}. +#' @param genome Genome build. Default \code{"GRCh38"}. +#' @param n Placeholder per-variant sample size. Default \code{1000}. +#' @param a1,a2 Placeholder alleles. Defaults \code{"A"} / \code{"G"}. +#' @param role Tag stored in the \code{qcInfo} record. Default \code{"mash"}. +#' @return A \code{\link{QtlSumStats}} with one entry per condition (column). +#' @seealso \code{\link{qtlSumStatsFromZMatrix}}, \code{\link{mashModelFit}} +#' @importFrom GenomicRanges GRanges +#' @importFrom IRanges IRanges +#' @export +qtlSumStatsFromBetaMatrix <- function(bhat, shat, study, ldSketch = NULL, + context = colnames(bhat), trait = "mash", + genome = "GRCh38", n = 1000L, + a1 = "A", a2 = "G", role = "mash") { + if (!is.matrix(bhat) || !is.numeric(bhat)) { + stop("qtlSumStatsFromBetaMatrix: `bhat` must be a numeric variants x conditions matrix.") + } + if (!is.matrix(shat) || !is.numeric(shat)) { + stop("qtlSumStatsFromBetaMatrix: `shat` must be a numeric variants x conditions matrix.") + } + if (!identical(dim(bhat), dim(shat))) { + stop(sprintf(paste0("qtlSumStatsFromBetaMatrix: `bhat` (%s) and `shat` (%s) ", + "must have identical dimensions."), + paste(dim(bhat), collapse = "x"), paste(dim(shat), collapse = "x"))) + } + vids <- rownames(bhat) + if (is.null(vids)) vids <- paste0("var", seq_len(nrow(bhat))) + .qtlSumStatsFromMatrix( + vids = vids, nCond = ncol(bhat), study = study, ldSketch = ldSketch, + context = context, trait = trait, genome = genome, role = role, + mcolFn = function(j) S4Vectors::DataFrame( + SNP = vids, A1 = rep(a1, length(vids)), A2 = rep(a2, length(vids)), + BETA = as.numeric(bhat[, j]), SE = as.numeric(shat[, j]), + Z = as.numeric(bhat[, j] / shat[, j]), + N = rep(as.integer(n), length(vids)))) +} + +# Internal: shared assembly for the z / beta matrix constructors. Recycles the +# context / trait labels, decodes chrom/pos from the variant ids (synthesising +# where they don't parse), builds one GRanges entry per condition with mcols +# from `mcolFn(j)`, and wraps the entries as a QtlSumStats. +# @noRd +.qtlSumStatsFromMatrix <- function(vids, nCond, study, ldSketch, context, trait, + genome, role, mcolFn) { + context <- .qszmRecycle(context, nCond, "context") + trait <- .qszmRecycle(trait, nCond, "trait") # Decode chrom/pos from the variant ids; synthesise where they do not parse. parsed <- tryCatch(suppressWarnings(parseVariantId(vids)), error = function(e) NULL) @@ -289,9 +611,7 @@ qtlSumStatsFromZMatrix <- function(z, study, ldSketch, entries <- lapply(seq_len(nCond), function(j) { gr <- GenomicRanges::GRanges( seqnames = chrom, ranges = IRanges::IRanges(start = pos, width = 1L)) - S4Vectors::mcols(gr) <- S4Vectors::DataFrame( - SNP = vids, A1 = rep(a1, length(vids)), A2 = rep(a2, length(vids)), - Z = as.numeric(z[, j]), N = rep(as.integer(n), length(vids))) + S4Vectors::mcols(gr) <- mcolFn(j) gr }) QtlSumStats( @@ -305,21 +625,20 @@ qtlSumStatsFromZMatrix <- function(z, study, ldSketch, } # Internal: recycle a condition-label argument (context / trait) to one value -# per column of the Z matrix. Accepts a single value (recycled to every column) -# or a vector of length ncol(z); errors otherwise -- including NULL, which is -# how `context = colnames(z)` arrives when the matrix has no column names. +# per matrix column. Accepts a single value (recycled to every column) or a +# vector of length ncol; errors otherwise -- including NULL, which is how +# `context = colnames(x)` arrives when the matrix has no column names. .qszmRecycle <- function(v, n, what) { if (is.null(v)) { - stop(sprintf(paste0("qtlSumStatsFromZMatrix: `%s` is NULL; pass a length-1 ", - "or length-%d value (or give `z` column names)."), - what, n)) + stop(sprintf(paste0("qtlSumStats matrix constructor: `%s` is NULL; pass a ", + "length-1 or length-%d value (or give the matrix column ", + "names)."), what, n)) } v <- as.character(v) if (length(v) == 1L) return(rep(v, n)) if (length(v) == n) return(v) - stop(sprintf( - "qtlSumStatsFromZMatrix: `%s` must be length 1 or ncol(z)=%d, got %d.", - what, n, length(v))) + stop(sprintf(paste0("qtlSumStats matrix constructor: `%s` must be length 1 or ", + "ncol=%d, got %d."), what, n, length(v))) } # Internal: convert a single SumStats object (post-QC) into a (Bhat, Shat) diff --git a/R/overlapTopLoci.R b/R/overlapTopLoci.R new file mode 100644 index 00000000..4c18326b --- /dev/null +++ b/R/overlapTopLoci.R @@ -0,0 +1,106 @@ +#' Overlap QTL and GWAS top loci by allele-aware variant matching +#' +#' Intersect the top-loci tables of a \code{QtlFineMappingResult} and a +#' \code{GwasFineMappingResult} on shared variants, matched with pecotmr's +#' allele-aware \code{\link{matchVariants}} (handling strand flips / ref-alt +#' swaps rather than naive id equality). The GWAS side is harmonized to the QTL +#' orientation: its signed effect columns (\code{beta}, \code{z}, +#' \code{conditional_effect}) are sign-flipped and its effect-allele frequency +#' (\code{af}) is complemented wherever a swap occurred. The result keeps the +#' variant key columns once (from the QTL, the reference orientation) and +#' prefixes every other column \code{qtl_} / \code{gwas_}. A variant shared +#' across several QTL contexts and/or GWAS studies yields one row per +#' (QTL entry x GWAS entry) pair (a wide cross-product per variant). +#' +#' @param qtl A \code{QtlFineMappingResult}. +#' @param gwas A \code{GwasFineMappingResult}. +#' @param signalCutoff PIP cutoff forwarded to \code{\link{getTopLoci}} for both +#' inputs. Default 0.025. +#' @param type \code{"data.frame"} (default) or \code{"GRanges"}. +#' @param ... Ignored. +#' @return A \code{data.frame} (or \code{GRanges}) keyed on the QTL variant +#' (\code{variant_id, chrom, pos, A1, A2}) with all other columns prefixed +#' \code{qtl_} / \code{gwas_}. Zero rows when there is no allele-aware overlap. +#' @seealso \code{\link{getTopLoci}}, \code{\link{matchVariants}} +#' @include AllGenerics.R AllClasses.R QtlFineMappingResult.R GwasFineMappingResult.R +#' @export +setGeneric("overlapTopLoci", + function(qtl, gwas, ...) standardGeneric("overlapTopLoci")) + +#' @rdname overlapTopLoci +#' @export +setMethod("overlapTopLoci", + signature("QtlFineMappingResult", "GwasFineMappingResult"), + function(qtl, gwas, signalCutoff = 0.025, + type = c("data.frame", "GRanges"), ...) { + type <- match.arg(type) + keyCols <- c("variant_id", "chrom", "pos", "A1", "A2") + coordCols <- c("chrom", "pos", "A1", "A2") + + qtlTl <- as.data.frame(getTopLoci(qtl, signalCutoff = signalCutoff)) + gwasTl <- as.data.frame(getTopLoci(gwas, signalCutoff = signalCutoff)) + + prefixNonKey <- function(df, pfx) + stats::setNames(df, ifelse(names(df) %in% keyCols, names(df), + paste0(pfx, names(df)))) + # The GWAS side contributes only variant_id (the join key) + its non-key + # columns; the shared coordinate columns come from the QTL side. + emptyMerge <- function() { + qp <- prefixNonKey(qtlTl[0, , drop = FALSE], "qtl_") + gp <- prefixNonKey( + gwasTl[0, setdiff(names(gwasTl), coordCols), drop = FALSE], "gwas_") + # A collection with no signal above the cutoff yields an identity-only + # getTopLoci frame (study/context/trait/method) that carries no + # variant_id; restore the join key so the empty merge still resolves + # instead of erroring in merge()'s `by` check. + if (!"variant_id" %in% names(qp)) qp$variant_id <- character(0) + if (!"variant_id" %in% names(gp)) gp$variant_id <- character(0) + merge(qp, gp, by = "variant_id") + } + finish <- function(df) if (type == "GRanges") .overlapToGRanges(df) else df + + if (nrow(qtlTl) == 0L || nrow(gwasTl) == 0L) return(finish(emptyMerge())) + + # Allele-aware correspondence between the unique QTL and GWAS variant sets. + # target = GWAS, ref = QTL, so `sign` is the flip applied to the GWAS side. + uq <- unique(qtlTl$variant_id) + ug <- unique(gwasTl$variant_id) + m <- matchVariants(ug, uq, allowFlip = TRUE) + if (length(m$idxA) == 0L) return(finish(emptyMerge())) + map <- data.frame(gwas_vid = ug[m$idxA], canon_vid = uq[m$idxB], + .sign = as.numeric(m$sign), stringsAsFactors = FALSE) + + # Relabel every GWAS row to the canonical (QTL-orientation) variant, and + # apply the swap to its signed effects + effect-allele frequency. + g <- merge(gwasTl, map, by.x = "variant_id", by.y = "gwas_vid") + # Unreachable defensive guard: map$gwas_vid is drawn from gwasTl$variant_id, + # so this inner merge can never drop every row (length(m$idxA) > 0 here). + if (nrow(g) == 0L) return(finish(emptyMerge())) # nocov + for (cc in intersect(c("beta", "z", "conditional_effect"), names(g))) + g[[cc]] <- g[[cc]] * g$.sign + if ("af" %in% names(g)) + g$af <- ifelse(g$.sign < 0 & !is.na(g$af), 1 - g$af, g$af) + g$variant_id <- g$canon_vid + g <- g[, setdiff(names(g), c(coordCols, "canon_vid", ".sign")), drop = FALSE] + + # Wide cross-product per shared variant, variant key kept once (QTL side). + merged <- merge(prefixNonKey(qtlTl, "qtl_"), prefixNonKey(g, "gwas_"), + by = "variant_id") + # Restore key-column order (merge puts the `by` column first). + ordered <- c(intersect(keyCols, names(merged)), + setdiff(names(merged), keyCols)) + finish(merged[, ordered, drop = FALSE]) + }) + +# Build a GRanges from an overlap table: variants as width-1 ranges, all other +# columns (qtl_* / gwas_*) as mcols. +# @noRd +.overlapToGRanges <- function(df) { + if (is.null(df) || nrow(df) == 0L) return(GenomicRanges::GRanges()) + p <- parseVariantId(df$variant_id) + gr <- GenomicRanges::GRanges( + seqnames = paste0("chr", p$chrom), + ranges = IRanges::IRanges(start = p$pos, width = 1L)) + S4Vectors::mcols(gr) <- S4Vectors::DataFrame(df, check.names = FALSE) + gr +} diff --git a/R/qtlAssociationPostprocess.R b/R/qtlAssociationPostprocess.R new file mode 100644 index 00000000..045d6502 --- /dev/null +++ b/R/qtlAssociationPostprocess.R @@ -0,0 +1,273 @@ +# ============================================================================= +# Hierarchical multiple-testing correction for cis-QTL association statistics. +# +# QtlSumStats-native port of the (retired) inst/code/tensorqtl_postprocessor.R +# engine. The input is a per-gene QtlSumStats: one ROW per gene/trait carrying +# the regional summary as row columns (n_variants [+ n_variants_filtered]; for +# permutation p_beta / q_beta / beta_shape1 / beta_shape2), and each ROW's +# ENTRY a per-variant GRanges with `P` (p-value) + optional `af` / +# tss_distance / tes_distance / qvalue mcols. It returns the SAME object +# enriched with the corrected-statistic columns. No file I/O, no globbing (that +# stays in the wrapper); no method key and no new class (the result is enriched +# summary statistics). Significance is never stored -- see getSignificantQtls(). +# +# ALL multiple-testing math uses established package functions: +# Bonferroni -> stats::p.adjust(method="bonferroni", n = ) +# BH-FDR -> stats::p.adjust(method="fdr") +# Storey q -> qvalue::qvalue (NO hand-rolled BH-as-qvalue fallback) +# perm thresh-> stats::qbeta (empirical bracketing feeds the beta quantile) +# ============================================================================= + +# Storey q-values via the Bioconductor qvalue package, with the qvalue-NATIVE +# edge-case retries only (never a hand-rolled substitute): lambda=0 for +# missing/infinite handling, bootstrap pi0 for the "pi0 <= 0" degenerate case. +# Returns a numeric vector aligned to `p`. +.qapSafeQvalue <- function(p) { + if (!requireNamespace("qvalue", quietly = TRUE)) { + # nocov start (optional-package guard; qvalue is Suggests-only) + stop("qtlAssociationPostprocess: the 'qvalue' package is required for ", + "Storey q-values. Install Bioconductor 'qvalue'.") + # nocov end + } + tryCatch( + qvalue::qvalue(p)$qvalues, + error = function(e) { + if (grepl("missing or infinite", conditionMessage(e))) { + qvalue::qvalue(p, lambda = 0)$qvalues + } else if (grepl("pi0 <= 0", conditionMessage(e))) { + maxP <- max(p, na.rm = TRUE) + lambdaSeq <- seq(0, min(0.9, maxP * 0.95), length.out = 10) + qvalue::qvalue(p, lambda = lambdaSeq, pi0.method = "bootstrap")$qvalues + } else { + stop("qtlAssociationPostprocess: qvalue::qvalue failed (", conditionMessage(e), + "). Not substituting a hand-rolled q-value.") + } + }) +} + +# Event-level global adjustment of a per-gene p-value vector: Benjamini-Hochberg +# FDR (stats::p.adjust) and Storey q (qvalue). Returns list(fdr=, q=). +.qapGlobalAdjust <- function(eventP) { + list(fdr = stats::p.adjust(eventP, method = "fdr"), + q = .qapSafeQvalue(eventP)) +} + +# Per-gene permutation nominal p-value threshold (FastQTL/TensorQTL): find the +# empirical p_beta cutoff that separates q_beta-significant from non-significant +# genes, then map it through each gene's beta distribution with stats::qbeta. +# The lb/ub bracketing is the FastQTL algorithm (no package equivalent); the +# distribution math is stats::qbeta. Returns a per-gene numeric vector. +.qapPermutationNominalThreshold <- function(pBeta, qBeta, shape1, shape2, + fdrThreshold) { + out <- rep(NA_real_, length(pBeta)) + ok <- !is.na(pBeta) & !is.na(qBeta) + lb <- sort(pBeta[ok & qBeta <= fdrThreshold]) # passing p_beta values + ub <- sort(pBeta[ok & qBeta > fdrThreshold]) # failing p_beta values + if (length(lb) == 0L) return(out) # no significant events + lbVal <- lb[length(lb)] # max passing p_beta + thr <- if (length(ub) > 0L) (lbVal + ub[1L]) / 2 else lbVal + stats::qbeta(thr, shape1, shape2) # vectorised over per-gene shapes +} + +# Per-variant MAF + cis-window keep mask (the FILTERED-flavour restriction) from +# an entry's af / tss_distance / tes_distance mcols. Shared by the correction +# and the significance derivation so the filtered set is defined once. +.qapFilterKeep <- function(mc, mafCutoff, cisWindow, afCol, nVar) { + keep <- rep(TRUE, nVar) + if (mafCutoff > 0 && !is.null(mc[[afCol]])) { + af <- mc[[afCol]] + keep <- keep & (pmin(af, 1 - af) > mafCutoff) + } + if (cisWindow > 0 && !is.null(mc$tss_distance) && !is.null(mc$tes_distance)) + keep <- keep & (mc$tss_distance >= -cisWindow & mc$tes_distance <= cisWindow) + keep +} + +# Per-gene logical masks of significant variants under a correction method (the +# derived significance, never stored). `method` is one of permutation, +# bonferroni_original, bonferroni_filtered, qvalue; `threshold` defaults to the +# fdrThreshold stashed by qtlAssociationPostprocess. Uses the SAME package math +# as the correction (p.adjust for the Bonferroni-adjusted per-variant p). +.qapSignificanceMask <- function(x, method, threshold = NULL) { + recipe <- x@qcInfo$associationPostprocess + if (is.null(recipe)) + stop("This QtlSumStats was not produced by qtlAssociationPostprocess(); ", + "no significance recipe to derive from.") + if (is.null(threshold)) threshold <- recipe$fdrThreshold + pcol <- recipe$pvalueCol; afcol <- recipe$afCol + nrows <- nrow(x) + masks <- lapply(seq_len(nrows), function(i) + rep(FALSE, length(S4Vectors::mcols(x$entry[[i]])[[pcol]]))) + + if (method == "permutation") { + if (is.null(x$p_nominal_threshold)) + stop("getSignificantQtls: no p_nominal_threshold (run the permutation method).") + thr <- as.numeric(x$p_nominal_threshold) + for (i in seq_len(nrows)) { + if (is.na(thr[i])) next + pv <- S4Vectors::mcols(x$entry[[i]])[[pcol]] + masks[[i]] <- !is.na(pv) & pv < thr[i] + } + } else if (method %in% c("bonferroni_original", "bonferroni_filtered")) { + flav <- sub("bonferroni_", "", method) + fdrCol <- paste0("fdr_bonferroni_min_", flav) + pMinCol <- paste0("p_bonferroni_min_", flav) + nCol <- if (flav == "filtered") "n_variants_filtered" else "n_variants" + if (is.null(x[[fdrCol]])) + stop("getSignificantQtls: '", method, "' columns absent; recompute with the ", + "matching flavour.") + sig <- as.numeric(x[[fdrCol]]) < threshold; sig[is.na(sig)] <- FALSE + if (any(sig)) { + varThr <- max(as.numeric(x[[pMinCol]])[sig], na.rm = TRUE) # global scalar + nVar <- as.numeric(x[[nCol]]) + for (i in seq_len(nrows)) { + mc <- S4Vectors::mcols(x$entry[[i]]); pv <- mc[[pcol]] + keep <- pmin(1, pv * nVar[i]) <= varThr + if (flav == "filtered") + keep <- keep & .qapFilterKeep(mc, recipe$mafCutoff, recipe$cisWindow, + afcol, length(pv)) + masks[[i]] <- keep & !is.na(keep) + } + } + } else if (method == "qvalue") { + qCol <- if (!is.null(x$q_beta)) "q_beta" else "q_bonferroni_min_original" + if (is.null(x[[qCol]])) + stop("getSignificantQtls: no event q-value column (q_beta / q_bonferroni_min_original).") + sig <- as.numeric(x[[qCol]]) < threshold; sig[is.na(sig)] <- FALSE + for (i in seq_len(nrows)) { + mc <- S4Vectors::mcols(x$entry[[i]]) + if (isTRUE(sig[i]) && !is.null(mc$qvalue)) + masks[[i]] <- !is.na(mc$qvalue) & mc$qvalue < threshold + } + } + masks +} + +#' @rdname getSignificantQtls +#' @param method Correction method whose significant variants to extract: +#' \code{"permutation"}, \code{"bonferroni_original"}, +#' \code{"bonferroni_filtered"}, or \code{"qvalue"}. +#' @param threshold FDR threshold (defaults to the value stashed by +#' \code{qtlAssociationPostprocess}). +#' @export +setMethod("getSignificantQtls", "QtlSumStats", + function(x, method = c("permutation", "bonferroni_original", + "bonferroni_filtered", "qvalue"), + threshold = NULL) { + method <- match.arg(method) + masks <- .qapSignificanceMask(x, method, threshold) + pieces <- lapply(seq_len(nrow(x)), function(i) { + gr <- x$entry[[i]][masks[[i]]] + if (length(gr) == 0L) return(NULL) + gr$study <- as.character(x$study)[i] + gr$context <- as.character(x$context)[i] + gr$trait <- as.character(x$trait)[i] + gr + }) + pieces <- pieces[!vapply(pieces, is.null, logical(1))] + if (length(pieces) == 0L) return(x$entry[[1L]][0L]) + do.call(c, pieces) + } +) + +# Rebuild a QtlSumStats with extra row columns added + a new qcInfo. Column +# assignment on the S4 subclass itself coerces per-element, so we coerce to a +# plain DFrame, add the columns, and re-wrap (the same rebuild idiom as subsetChr). +.qapRebuild <- function(x, newCols, qcInfo) { + df <- methods::as(x, "DFrame") + for (nm in names(newCols)) df[[nm]] <- newCols[[nm]] + obj <- methods::new("QtlSumStats", df, + ldSketch = x@ldSketch, genome = x@genome, qcInfo = qcInfo) + methods::validObject(obj) + obj +} + +#' @rdname qtlAssociationPostprocess +#' @param fdrThreshold Event- and variant-level FDR threshold (default 0.05). +#' @param mafCutoff Minor-allele-frequency cutoff for the FILTERED Bonferroni +#' flavour (fold of the per-variant \code{af} mcol). \code{0} disables it. +#' @param cisWindow cis-window (bp) for the FILTERED Bonferroni flavour, applied +#' to the per-variant \code{tss_distance}/\code{tes_distance} mcols. \code{0} +#' disables it. When either \code{mafCutoff} or \code{cisWindow} is > 0 the +#' \code{*_filtered} columns are produced (requires the \code{n_variants_filtered} +#' row column). +#' @param methods Correction families to compute: any of \code{"permutation"} +#' (needs \code{p_beta}/\code{beta_shape1}/\code{beta_shape2}) and +#' \code{"bonferroni"} (needs \code{n_variants}). The q-value SNP method adds +#' no stored column -- it is a significance query (see \code{getSignificantQtls}). +#' @param pvalueCol,afCol Entry mcol names for the per-variant p-value / allele +#' frequency (defaults \code{"P"} / \code{"af"}). +#' @export +setMethod("qtlAssociationPostprocess", "QtlSumStats", + function(x, fdrThreshold = 0.05, mafCutoff = 0, cisWindow = 0, + methods = c("permutation", "bonferroni"), + pvalueCol = "P", afCol = "af") { + methods <- match.arg(methods, several.ok = TRUE) + n <- nrow(x) + filtering <- (mafCutoff > 0 || cisWindow > 0) + newCols <- list() + + # ---- local Bonferroni: per-gene min adjusted p (original [+ filtered]) ---- + if ("bonferroni" %in% methods) { + if (is.null(x$n_variants)) + stop("qtlAssociationPostprocess: `n_variants` row column is required ", + "for the Bonferroni correction.") + nVar <- as.numeric(x$n_variants) + nVarFilt <- if (!is.null(x$n_variants_filtered)) + as.numeric(x$n_variants_filtered) else NULL + if (filtering && is.null(nVarFilt)) + stop("qtlAssociationPostprocess: `n_variants_filtered` row column is ", + "required when mafCutoff/cisWindow > 0.") + + pBonfOrig <- rep(NA_real_, n) + pBonfFilt <- rep(NA_real_, n) + for (i in seq_len(n)) { + mc <- S4Vectors::mcols(x$entry[[i]]) + pv <- mc[[pvalueCol]] + if (is.null(pv) || length(pv) == 0L) next + # The upstream p-value pre-filter always retains the global-min variant, + # so min over the (possibly pre-filtered) entry is the exact per-gene min. + pBonfOrig[i] <- min(stats::p.adjust(pv, method = "bonferroni", n = nVar[i])) + if (filtering) { + keep <- .qapFilterKeep(mc, mafCutoff, cisWindow, afCol, length(pv)) + if (any(keep)) + pBonfFilt[i] <- min(stats::p.adjust(pv[keep], method = "bonferroni", + n = nVarFilt[i])) + } + } + + newCols$p_bonferroni_min_original <- pBonfOrig + gaO <- .qapGlobalAdjust(pBonfOrig) + newCols$fdr_bonferroni_min_original <- gaO$fdr + newCols$q_bonferroni_min_original <- gaO$q + if (filtering) { + newCols$p_bonferroni_min_filtered <- pBonfFilt + gaF <- .qapGlobalAdjust(pBonfFilt) + newCols$fdr_bonferroni_min_filtered <- gaF$fdr + newCols$q_bonferroni_min_filtered <- gaF$q + } + } + + # ---- permutation: BH-FDR of p_beta + per-gene nominal p threshold ---- + if ("permutation" %in% methods && !is.null(x$p_beta)) { + pBeta <- as.numeric(x$p_beta) + qBeta <- if (!is.null(x$q_beta)) as.numeric(x$q_beta) else .qapSafeQvalue(pBeta) + if (is.null(x$q_beta)) newCols$q_beta <- qBeta + newCols$fdr_beta <- stats::p.adjust(pBeta, method = "fdr") + if (!is.null(x$beta_shape1) && !is.null(x$beta_shape2)) { + newCols$p_nominal_threshold <- .qapPermutationNominalThreshold( + pBeta, qBeta, as.numeric(x$beta_shape1), + as.numeric(x$beta_shape2), fdrThreshold) + } + } + + # Stash the correction recipe so getSignificantQtls / annotateSignificance + # can reproduce significance cheaply (thresholds, not flags). + qc <- x@qcInfo + qc$associationPostprocess <- list( + fdrThreshold = fdrThreshold, mafCutoff = mafCutoff, + cisWindow = cisWindow, methods = methods, + pvalueCol = pvalueCol, afCol = afCol) + .qapRebuild(x, newCols, qc) + } +) diff --git a/R/qtlSumStats.R b/R/qtlSumStats.R index cbca4ab3..45b300ec 100644 --- a/R/qtlSumStats.R +++ b/R/qtlSumStats.R @@ -16,6 +16,9 @@ setClass("QtlSumStats", contains = "SumStatsBase", validity = function(object) { errors <- character() + if (!is.null(object@ldSketch) && + !methods::is(object@ldSketch, "GenotypeHandle")) + errors <- c(errors, "'ldSketch' must be a GenotypeHandle or NULL") required <- c("study", "context", "trait", "entry") missingCols <- setdiff(required, names(object)) if (length(missingCols) > 0L) @@ -26,6 +29,7 @@ setClass("QtlSumStats", "'genome' slot must be a single non-empty character string") if (!is.list(object@qcInfo)) errors <- c(errors, "'qcInfo' slot must be a list") + errors <- c(errors, .validateTraitPosColumn(object)) if (length(errors) == 0L) { if (length(object$entry) != nrow(object)) errors <- c(errors, @@ -88,11 +92,11 @@ NULL #' @param ... Additional per-tuple columns to attach to the collection. #' @return A \code{QtlSumStats} object. #' @export -QtlSumStats <- function(study, context, trait, entry, genome, ldSketch, - varY = NA_real_, qcInfo = list(), ...) { +QtlSumStats <- function(study, context, trait, entry, genome, ldSketch = NULL, + varY = NA_real_, qcInfo = list(), traitPos = NULL, ...) { if (missing(study) || missing(context) || missing(trait) || - missing(entry) || missing(genome) || missing(ldSketch)) { - stop("`study`, `context`, `trait`, `entry`, `genome`, and `ldSketch` ", + missing(entry) || missing(genome)) { + stop("`study`, `context`, `trait`, `entry`, and `genome` ", "are all required.") } if (length(genome) != 1L) { @@ -112,6 +116,14 @@ QtlSumStats <- function(study, context, trait, entry, genome, ldSketch, stop("`varY` must have length 1 or length(study).") } + # Auto-fill tss_distance / tes_distance on each entry from the trait position + # when supplied (builds on the traitPos provenance). The authoritative + # traitPos shape check happens in .appendTraitPosCol below. + if (!is.null(traitPos) && methods::is(traitPos, "GRanges") && + length(traitPos) == n) { + entry <- .appendTraitDistances(entry, traitPos) + } + cols <- list( study = as.character(study), context = as.character(context), @@ -119,6 +131,10 @@ QtlSumStats <- function(study, context, trait, entry, genome, ldSketch, entry = S4Vectors::SimpleList(entry), varY = as.numeric(varY) ) + # Optional trait-position provenance (one GRanges per trait; TSS = start()), + # carried forward into QtlFineMappingResult / TwasWeights since the true trait + # position cannot be inferred from summary statistics alone. + cols <- .appendTraitPosCol(cols, traitPos, n) extras <- list(...) for (nm in names(extras)) cols[[nm]] <- extras[[nm]] df <- do.call(S4Vectors::DataFrame, c(cols, list(check.names = FALSE))) @@ -131,6 +147,31 @@ QtlSumStats <- function(study, context, trait, entry, genome, ldSketch, obj } +# Annotate each entry's variants with tss_distance / tes_distance from the +# trait-position GRanges (one range per tuple, aligned to `entry`): variant +# position minus the trait's TSS (= start of the trait-position range) and TES +# (= end). For a single-base trait position start() == end(), so the two are +# identical (as expected for point positions). Existing tss_distance / +# tes_distance mcols are preserved (not clobbered). `@noRd` +.appendTraitDistances <- function(entry, traitPos) { + if (is.null(traitPos)) return(entry) + lapply(seq_along(entry), function(i) { + gr <- entry[[i]] + if (length(gr) == 0L) return(gr) + tp <- traitPos[i] + tssPos <- suppressWarnings(GenomicRanges::start(tp)) + tesPos <- suppressWarnings(GenomicRanges::end(tp)) + if (length(tssPos) == 0L || is.na(tssPos)) return(gr) + pos <- GenomicRanges::start(gr) + 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 + if (is.null(mc[["tes_distance"]])) mc[["tes_distance"]] <- pos - tesPos + S4Vectors::mcols(gr) <- mc + gr + }) +} + # ============================================================================= # Accessors # ============================================================================= @@ -167,11 +208,27 @@ QtlSumStats <- function(study, context, trait, entry, genome, ldSketch, } #' @rdname getSumStats +#' @param annotateSignificance Optional correction-method name +#' (\code{"permutation"} / \code{"bonferroni_original"} / +#' \code{"bonferroni_filtered"} / \code{"qvalue"}). When set on a QtlSumStats +#' enriched by \code{\link{qtlAssociationPostprocess}}, a logical +#' \code{significant} mcol for that method is added to the returned entry (the +#' significance is derived on the fly, not stored). Flat export flattens this +#' full entry GRanges (all mcols) directly; note \code{\link{getSumstatDf}} is +#' a fixed GWAS-schema view and does not carry the association columns. #' @export setMethod("getSumStats", signature(x = "QtlSumStats"), - function(x, study = NULL, context = NULL, trait = NULL, ...) { + function(x, study = NULL, context = NULL, trait = NULL, + annotateSignificance = NULL, ...) { idx <- .qtlSumStatsSelectRow(x, study, context, trait) - x$entry[[idx]] + gr <- x$entry[[idx]] + if (!is.null(annotateSignificance)) { + m <- match.arg(annotateSignificance, + c("permutation", "bonferroni_original", + "bonferroni_filtered", "qvalue")) + S4Vectors::mcols(gr)[["significant"]] <- .qapSignificanceMask(x, m)[[idx]] + } + gr } ) @@ -239,6 +296,20 @@ setMethod("getContexts", "QtlSumStats", setMethod("getTraits", "QtlSumStats", function(x) unique(as.character(x$trait))) +# Trait position provenance. Optional for a QtlSumStats -- it cannot be inferred +# from summary statistics, so it is only present when the caller supplied it. +# Returns the traitPos GRanges (whole column, or the rows matching `traitId`), +# or a scalar NA when no trait position was supplied. +#' @rdname getTraitPosition +#' @export +setMethod("getTraitPosition", "QtlSumStats", function(x, traitId = NULL, ...) { + tp <- .getTraitPosColumn(x) + if (!methods::is(tp, "GRanges") || is.null(traitId)) return(tp) + idx <- which(as.character(x$trait) %in% as.character(traitId)) + if (length(idx) == 0L) return(NA) + tp[idx] +}) + # ============================================================================= # Show method # ============================================================================= @@ -254,5 +325,7 @@ setMethod("show", "QtlSumStats", function(object) { length(unique(object$trait)))) } ld <- getLdSketch(object) - cat(sprintf(" LD sketch: %s @ %s\n", getFormat(ld), getPath(ld))) + cat(sprintf(" LD sketch: %s\n", + if (is.null(ld)) "none (LD-free)" + else sprintf("%s @ %s", getFormat(ld), getPath(ld)))) }) diff --git a/R/regularizedRegressionWrappers.R b/R/regularizedRegressionWrappers.R index 0aa7a598..2a142784 100644 --- a/R/regularizedRegressionWrappers.R +++ b/R/regularizedRegressionWrappers.R @@ -1543,7 +1543,7 @@ bLassoWeights <- function(X, y, nIter = 10000, burnIn = 2000, thin = 5, ...) { #' #' Fits a Dirichlet Process Regression model via `RcppDPR::fit_model` and #' returns the per-variant weights, computed as `beta + alpha` (matching -#' `RcppDPR:::predict.DPR_Model`, which uses `(beta + alpha) %*% x_new + pheno_mean`). +#' RcppDPR's internal `predict.DPR_Model`, which uses `(beta + alpha) %*% x_new + pheno_mean`). #' #' By default the variational Bayes (`VB`) fitting method is used, which is #' fast and deterministic. The user may switch to `Gibbs` or `Adaptive_Gibbs` diff --git a/R/sldscWrapper.R b/R/sldscWrapper.R index 51ae6e74..09da46c0 100644 --- a/R/sldscWrapper.R +++ b/R/sldscWrapper.R @@ -400,8 +400,9 @@ standardizeSldscTrait <- function(sldscData, trait, mode = c("single", "joint"), #' @title Random-effects meta-analysis of S-LDSC quantities across traits #' -#' @description DerSimonian-Laird random-effects meta-analysis of one S-LDSC -#' quantity for one annotation across multiple traits. +#' @description Random-effects meta-analysis (DerSimonian-Laird, via +#' \code{metafor::rma}) of one S-LDSC quantity for one annotation across +#' multiple traits. #' #' @details Per-trait \eqn{SE_i} sources: #' - `quantity = "tauStar"`: jackknife SE from per-block \eqn{\tau^*}. @@ -449,7 +450,7 @@ metaSldscRandom <- function(perTraitEstimates, category, nTraits = length(means), traitsUsed = used, tau2 = NA_real_)) } - meta <- metaRandomEffects(means, ses) + meta <- .rmaMeta(means, ses) z <- meta$mean / meta$se p <- .zToPvalue(z) list( @@ -519,7 +520,8 @@ metaSldscRandom <- function(perTraitEstimates, category, #' Random-effects meta-analysis over a subset of sLDSC traits #' -#' Re-run the DerSimonian-Laird random-effects meta-analysis on a chosen subset +#' Re-run the random-effects meta-analysis (DerSimonian-Laird, via +#' \code{metafor::rma}) on a chosen subset #' of the per-trait standardised tables produced by #' \code{\link{sldscPostprocessingPipeline}} -- no regression is re-run, only the #' already-standardised per-trait estimates are re-meta'd. Powers a "meta on a diff --git a/R/tupleSelectors.R b/R/tupleSelectors.R index f528084b..1d2c6979 100644 --- a/R/tupleSelectors.R +++ b/R/tupleSelectors.R @@ -168,6 +168,40 @@ character(0) } +# Internal: trait-position provenance. One GRanges per trait carrying the +# molecular feature's OWN genomic coordinates (gene/peak range; TSS = start()), +# distinct from the fine-mapping `region`. The true trait position cannot be +# inferred from summary statistics, so it is threaded from QtlDataset rowRanges +# / an explicit QtlSumStats trait-position and carried onto QtlFineMappingResult +# and TwasWeights. Mirrors the `region` helpers above; absent for GWAS. +# traitPos is optional provenance: always known for a QtlDataset, but only known +# for a QtlSumStats when the caller supplied it (it cannot be inferred from +# summary statistics). When the column is absent we return a scalar NA rather +# than an empty GRanges, so getTraitPosition() reports "no trait position" +# honestly instead of a zero-length range. +.getTraitPosColumn <- function(x) { + if ("traitPos" %in% names(x)) x[["traitPos"]] else NA +} + +.appendTraitPosCol <- function(cols, traitPos, n) { + if (is.null(traitPos)) return(cols) + if (!methods::is(traitPos, "GRanges")) + stop("`traitPos` must be a GRanges (one range per row) or NULL.") + if (length(traitPos) != n) + stop("`traitPos` must have the same length as `study`.") + cols[["traitPos"]] <- traitPos + cols +} + +.validateTraitPosColumn <- function(object) { + if (!("traitPos" %in% names(object))) return(character(0)) + if (!methods::is(object[["traitPos"]], "GRanges")) + return("'traitPos' column must be a GRanges") + if (length(object[["traitPos"]]) != nrow(object)) + return("'traitPos' column must have one range per row") + character(0) +} + # Internal: a length-n "unknown" column matching the type of `exemplar`, used # to pad a collection that lacks an optional column before a union row-bind. # Character -> NA; GRanges -> a 0-width chrUn sentinel range; else NA. @@ -193,7 +227,7 @@ allCols <- Reduce(union, lapply(parts, names)) exemplar <- function(cn) { for (p in parts) if (cn %in% names(p)) return(p[[cn]]) - NULL + NULL # nocov (unreachable: cn is always drawn from allCols, so some part has it) } combined <- lapply(allCols, function(cn) { pieces <- lapply(parts, function(p) diff --git a/R/twasWeights.R b/R/twasWeights.R index b92274ff..e18f35b4 100644 --- a/R/twasWeights.R +++ b/R/twasWeights.R @@ -35,6 +35,7 @@ setClass("TwasWeights", "every element of the `entry` column must be a TwasWeightsEntry") # Optional `region` provenance (one genomic anchor per row; non-key). errors <- c(errors, .validateRegionColumn(object)) + errors <- c(errors, .validateTraitPosColumn(object)) jointCols <- intersect( c("jointStudies", "jointContexts", "jointTraits"), names(object)) for (jc in jointCols) { @@ -154,6 +155,7 @@ TwasWeights <- function(study, context, trait, method, entry, jointContexts = NULL, jointTraits = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL) { n <- length(study) if (length(context) != n || length(trait) != n || length(method) != n || @@ -178,6 +180,7 @@ TwasWeights <- function(study, context, trait, method, entry, cols[[pair[[2L]]]] <- as.character(val) } cols <- .appendRegionCol(cols, region, n) + cols <- .appendTraitPosCol(cols, traitPos, n) df <- do.call(S4Vectors::DataFrame, c(cols, list(check.names = FALSE))) obj <- new("TwasWeights", df, ldSketch = ldSketch) @@ -189,6 +192,10 @@ TwasWeights <- function(study, context, trait, method, entry, #' @export setMethod("getRegion", "TwasWeights", function(x, ...) .getRegionColumn(x)) +#' @rdname getTraitPosition +#' @export +setMethod("getTraitPosition", "TwasWeights", function(x, ...) .getTraitPosColumn(x)) + #' @title Get a Single TWAS Weights Entry #' @description Return the \code{TwasWeightsEntry} for one #' \code{(study, context, trait, method)} row of a \code{TwasWeights} diff --git a/R/vcfWriter.R b/R/vcfWriter.R index f2d43d2a..8941b4a1 100644 --- a/R/vcfWriter.R +++ b/R/vcfWriter.R @@ -144,15 +144,32 @@ setMethod("writeSumstatsVcf", signature("FineMappingResultBase"), spec$study, spec$context %||% "_", spec$trait %||% "_", spec$method) - # Body of the VCF is exclusively marginal univariate effects — no - # posterior output. By design the fine-mapping write-out emits the - # marginal sumstats so consumers can run their own downstream - # analysis (coloc, TWAS, etc.) on a uniform per-variant table. - marginal <- getMarginalEffects(entry) - if (nrow(marginal) == 0) + # Per-variant body: the fine-mapping POSTERIOR (getTopLoci at signalCutoff 0 = + # every fitted variant, carrying pip / CS membership / conditional effect), + # joined to the MARGINAL univariate sumstats (getMarginalEffects) where those + # exist. mvSuSiE / fSuSiE have no marginal sumstats, so the posterior drives + # the variant set and supplies ES=conditional_effect + PIP + CS; univariate + # susie adds marginal ES=beta / SE / LP / AF on top. This restores the legacy + # create_vcf fields (ES / CS / PIP) the mv_susie cell wrote. + post <- tryCatch(as.data.frame(getTopLoci(entry, signalCutoff = 0)), + error = function(e) NULL) + marg <- tryCatch(as.data.frame(getMarginalEffects(entry)), + error = function(e) NULL) + hasPost <- !is.null(post) && nrow(post) > 0L + hasMarg <- !is.null(marg) && nrow(marg) > 0L + if (hasPost) { + base <- post + m <- if (hasMarg) marg[match(base$variant_id, marg$variant_id), , drop = FALSE] + else NULL + } else if (hasMarg) { + base <- marg; m <- marg + } else { stop("writeSumstatsVcf: entry [", sn, "] has no variants to write") + } + nSnps <- nrow(base) + col <- function(df, nm) if (!is.null(df) && nm %in% names(df)) df[[nm]] + else rep(NA, nSnps) - nSnps <- nrow(marginal) geno <- list() hdrRows <- character(0); hdrNum <- character(0) hdrType <- character(0); hdrDesc <- character(0) @@ -161,33 +178,78 @@ setMethod("writeSumstatsVcf", signature("FineMappingResultBase"), hdrRows <<- c(hdrRows, name); hdrNum <<- c(hdrNum, "A") hdrType <<- c(hdrType, type); hdrDesc <<- c(hdrDesc, desc) } - if (any(!is.na(marginal$beta))) - addGeno("ES", marginal$beta, "Float", - "Marginal univariate effect-size estimate (effect allele)") - if (any(!is.na(marginal$se))) - addGeno("SE", marginal$se, "Float", - "Standard error of the marginal effect-size estimate") - if (any(!is.na(marginal$p))) { - lp <- ifelse(is.na(marginal$p) | marginal$p <= 0, - NA_real_, -log10(marginal$p)) - addGeno("LP", lp, "Float", - "-log10 p-value of the marginal univariate effect") + # ES: posterior conditional effect (mvSuSiE/fSuSiE) when present, else the + # marginal univariate beta (univariate susie). + es <- col(base, "conditional_effect") + if (all(is.na(es))) es <- col(m, "beta") + if (any(!is.na(es))) + addGeno("ES", es, "Float", + "Effect size (posterior conditional effect, else marginal beta), effect allele") + se <- col(m, "se") + if (any(!is.na(se))) + addGeno("SE", se, "Float", "Standard error of the marginal effect-size estimate") + p <- col(m, "p") + if (any(!is.na(p))) { + lp <- ifelse(is.na(p) | p <= 0, NA_real_, -log10(p)) + addGeno("LP", lp, "Float", "-log10 p-value of the marginal univariate effect") + } + if (any(!is.na(col(m, "N")))) + addGeno("SS", as.integer(col(m, "N")), "Integer", "Sample size") + af <- col(base, "af"); if (all(is.na(af))) af <- col(m, "af") + if (any(!is.na(af))) + addGeno("AF", af, "Float", "Allele frequency (effect allele)") + # Posterior fields, only when a posterior table is available. + if (hasPost) { + pip <- col(base, "pip") + if (any(!is.na(pip))) + addGeno("PIP", pip, "Float", "Posterior inclusion probability") + lbf <- col(base, "logBF") + if (any(!is.na(lbf))) + addGeno("LBF", lbf, "Float", "Per-variant log Bayes factor (max single effect)") + lfsr <- col(base, "lfsr") + if (any(!is.na(lfsr))) + addGeno("LFSR", lfsr, "Float", "Local false sign rate (per-condition posterior)") + # Credible sets are DYNAMIC: pecotmr does not assume any fixed coverage, so + # we emit a CS (+ PUR) field for every cs_ + # column the pipeline actually produced (e.g. cs_95 -> CS95 / PUR95). The + # 50/70/95 defaults are an xqtl-protocol pipeline choice, not baked in here. + csCols <- grep("^cs_[0-9.]+$", names(base), value = TRUE) + for (cc in csCols) { + cov <- sub("^cs_", "", cc) + idx <- suppressWarnings(as.integer(sub(".*_", "", as.character(base[[cc]])))) + idx[is.na(idx)] <- 0L + addGeno(paste0("CS", cov), idx, "Integer", + sprintf("Credible-set index at %s%% coverage (0 = not captured)", cov)) + pc <- paste0(cc, "_purity") + if (pc %in% names(base)) { + pur <- suppressWarnings(as.numeric(base[[pc]])) + if (any(!is.na(pur))) + addGeno(paste0("PUR", cov), pur, "Float", + sprintf("Purity (min abs corr) of the %s%% credible set", cov)) + } + } + # Per-CS variant-level fullFit columns (within_cs_pip default scalar, and the + # wide within_cs_pip_ / cs_logbf_ / cs_effect_ / cs_effect_var_ + # sets when the topLoci was built with fullFit=TRUE). Emit each as an + # uppercase FORMAT field. + for (cc in grep("^(within_cs_pip|cs_logbf_|cs_effect_)", names(base), value = TRUE)) { + v <- suppressWarnings(as.numeric(base[[cc]])) + if (any(!is.na(v))) + addGeno(toupper(cc), v, "Float", + sprintf("Per-credible-set variant statistic (%s)", cc)) + } } - if (any(!is.na(marginal$N))) - addGeno("SS", as.integer(marginal$N), "Integer", "Sample size") - if (any(!is.na(marginal$af))) - addGeno("AF", marginal$af, "Float", "Allele frequency (effect allele)") genoHeader <- DataFrame( Number = hdrNum, Type = hdrType, Description = hdrDesc, row.names = hdrRows) .writeVcfImpl( - chrom = marginal$chrom, - pos = marginal$pos, - ref = marginal$A2, - alt = marginal$A1, - snpIds = marginal$variant_id, + chrom = col(base, "chrom"), + pos = col(base, "pos"), + ref = col(base, "A2"), + alt = col(base, "A1"), + snpIds = col(base, "variant_id"), geno = geno, genoHeader = genoHeader, sampleName = sn, diff --git a/_pkgdown.yml b/_pkgdown.yml index 89aac534..460f4f59 100644 --- a/_pkgdown.yml +++ b/_pkgdown.yml @@ -127,6 +127,7 @@ reference: - QtlDataset - QtlFineMappingResult - QtlSumStats + - qtlSumStatsFromBetaMatrix - qtlSumStatsFromZMatrix - SldscData - TwasWeights @@ -164,7 +165,11 @@ reference: - subtitle: "FineMappingEntry" contents: - adjustPips + - fsusieAffectedRegions + - fsusieCredibleBand + - getCredibleSetSummary - getCs + - getLbf - getMarginalEffects - getPip - getSusieFit @@ -204,8 +209,11 @@ reference: - subtitle: "GwasSumStats" contents: + - getBeta - getMaf - getN + - getP + - getSE - getSumStats - getSumstatDf - getVarY @@ -267,6 +275,7 @@ reference: - getResidualizedGenotypes - getResidualizedPhenotypes - getScaleResiduals + - getTraitPosition - subtitle: "QtlFineMappingResult" contents: @@ -275,7 +284,9 @@ reference: - subtitle: "QtlSumStats" contents: - getContexts + - getSignificantQtls - getTraits + - qtlAssociationPostprocess - subtitle: "SumStatsBase" contents: @@ -429,13 +440,13 @@ reference: - fsusieGetCs - fsusieWrapper - getSusieResult - - buildTopLoci - extractCsInfo - extractTopPipInfo - formatFinemappingOutput - lbfToAlpha - postprocessFinemappingFits - combineFineMappingResults + - overlapTopLoci - title: "TWAS" desc: > @@ -499,14 +510,28 @@ reference: contents: - combinePValues - - title: "mash helpers" + - title: "mash" desc: > - Utilities exposed by the mash track for posterior contrast - construction, mixture management, and meta-analysis. - contents: + The mash (multivariate adaptive shrinkage) track: the chainable steps + \code{mashInput} -> \code{mashResidualCorrelation} -> + \code{mashPriorCovariances} (or \code{mashCovarianceComponents}) -> + \code{mashModelFit} -> \code{mashPosterior} that \code{mashPipeline} is + built from, the posterior-contrast + feature-score layer, and the + supporting utilities for contrast construction and meta-analysis. + contents: + - mashInput + - mashResidualCorrelation + - mashCovarianceComponents + - mashPriorCovariances + - mashModelFit + - mashPosterior + - mashPosteriorContrast + - calculateFeatureScores + - nSignificantScore + - scoreFromCs - makePairwiseContrastCol - fitMashContrast - - metaAnalysisPerCell + - metaAnalysisPerCondition - sanitizeMashData - sliceMashData - updateMashModelCov @@ -548,7 +573,7 @@ reference: - gwas_sumstats_example - gwas_finemapping_example - qtl_finemapping_example - - multitraite_data + - multitrait_data - title: internal desc: > @@ -594,6 +619,7 @@ reference: # Implementation details with .Rd topics but no front-facing role. - as.data.frame.GwasSumStats - rescaleCovW0 + - ".fullFitColumns" - "getSumStats,GwasSumStats-method" footer: diff --git a/cleanup b/cleanup deleted file mode 100755 index 4109b212..00000000 --- a/cleanup +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -rm -f config.log config.status confdefs.h src/*.o src/*.so src/Makevars \ No newline at end of file diff --git a/configure b/configure deleted file mode 100755 index b4c60b28..00000000 --- a/configure +++ /dev/null @@ -1,8 +0,0 @@ -#!/bin/sh - -GSL_CFLAGS=`${R_HOME}/bin/Rscript -e "RcppGSL:::CFlags()"` -GSL_LIBS=`${R_HOME}/bin/Rscript -e "RcppGSL:::LdFlags()"` - -sed -e "s|@GSL_LIBS@|${GSL_LIBS}|" \ - -e "s|@GSL_CFLAGS@|${GSL_CFLAGS}|" \ - src/Makevars.in > src/Makevars \ No newline at end of file diff --git a/data/multitrait_data.RData b/data/multitrait_data.rda similarity index 100% rename from data/multitrait_data.RData rename to data/multitrait_data.rda diff --git a/inst/code/fastenloc_archive/README.md b/inst/code/fastenloc_archive/README.md deleted file mode 100644 index 7f1c436a..00000000 --- a/inst/code/fastenloc_archive/README.md +++ /dev/null @@ -1 +0,0 @@ -Downloaded from https://github.com/xqwen/fastenloc/tree/d4e2db1a7f17404c8267573acc69fc9b874e4c38 \ No newline at end of file diff --git a/inst/code/fastenloc_archive/controller.cc b/inst/code/fastenloc_archive/controller.cc deleted file mode 100644 index 45f0e510..00000000 --- a/inst/code/fastenloc_archive/controller.cc +++ /dev/null @@ -1,640 +0,0 @@ -#include "controller.h" -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include -#include - -void controller::load_eqtl(char *eqtl_file, char *tissue) -{ - - fprintf(stderr, "Processing eQTL annotations ... \n"); - ifstream dfile(eqtl_file, ios_base::in | ios_base::binary); - if (dfile.fail()) - { - fprintf(stderr, "\nError: can't open eQTL annotation file \"%s\". \n\n ", eqtl_file); - exit(1); - } - boost::iostreams::filtering_istream in; - - in.push(boost::iostreams::gzip_decompressor()); - if (in.fail()) - { - fprintf(stderr, "\nError: fail to decompress eQTL annotation file \"%s\", please check the file format.\n\n", eqtl_file); - exit(1); - } - in.push(dfile); - - string line; - istringstream ins; - - string target_tissue = string(tissue); - - string chr; - string pos; - string snp_id; // important - string allele1; - string allele2; - string content; - - string delim = "|"; - - int format_status = 0; - while (getline(in, line)) - { - - ins.clear(); - ins.str(line); - - if (ins >> chr >> pos >> snp_id >> allele1 >> allele2 >> content) - { - - format_status = 1; - - // passing content - size_t pos = 0; - string token; - - do - { - pos = content.find(delim); - token = content.substr(0, pos); - size_t pos1 = token.find("@"); - size_t pos2 = token.find("="); - size_t pos3 = token.find("["); - size_t pos4 = token.find("]"); - string sig_id; - string tissue_type; - if (pos1 != string::npos && pos2 - pos1 > 1) - { - tissue_type = token.substr(pos1 + 1, pos2 - pos1 - 1); - } - - sig_id = token.substr(0, pos1); - - // printf("sig id = %s %d %d\n",sig_id.c_str(),pos2,pos1); - string pip = token.substr(pos2 + 1, pos3 - pos2 - 1); - string sig_pip = token.substr(pos3 + 1, pos4 - pos3 - 1); - // processing - - if (strlen(tissue) == 0 || tissue_type.compare(target_tissue) == 0) - { - - if (snp_index.find(snp_id) == snp_index.end()) - { - snp_index[snp_id] = snp_vec.size(); - snp_vec.push_back(snp_id); - } - - if (eqtl_sig_index.find(sig_id) == eqtl_sig_index.end()) - { - eqtl_sig_index[sig_id] = eqtl_vec.size(); - sigCluster cluster; - cluster.id = sig_id; - cluster.cpip = 0; - eqtl_vec.push_back(cluster); - } - - int index = eqtl_sig_index[sig_id]; - double val = atof(pip.c_str()); - eqtl_vec[index].cpip += val; - eqtl_vec[index].snp_vec.push_back(snp_id); - eqtl_vec[index].pip_vec.push_back(val); - - // std::cout << snp_id<< " "<< sig_id<<" "<< tissue_type<<" "<< pip << " "<< sig_pip<< std::endl; - } - - content.erase(0, pos + delim.length()); - } while (pos != string::npos); - } - } - - if (format_status == 0) - { - fprintf(stderr, "\nError: unexpected format in eQTL annotation file \"%s\".\n\n", eqtl_file); - exit(1); - } - - double sum = 0; - for (int i = 0; i < eqtl_vec.size(); i++) - { - sum += eqtl_vec[i].cpip; - } - - if (sum == 0) - { - fprintf(stderr, "\nError: no eQTL annotated in \"%s\". \n\n", eqtl_file); - exit(1); - } - - fprintf(stderr, "read in %d SNPs, %d eQTL signal clusters, %.1f expected eQTLs\n\n", int(snp_vec.size()), int(eqtl_vec.size()), sum); - - P_eqtl = sum; - // fprintf(stderr, "%d %d %7.3e %f\n", int(snp_vec.size()), total_snp, P_eqtl, sum); -} - -void controller::load_gwas_torus(char *gwas_file) -{ - - fprintf(stderr, "Processing complex trait data ... \n"); - ifstream dfile(gwas_file, ios_base::in | ios_base::binary); - if (dfile.fail()) - { - fprintf(stderr, "\nError: can't open complex trait file \"%s\". \n\n ", gwas_file); - exit(1); - } - boost::iostreams::filtering_istream in; - - in.push(boost::iostreams::gzip_decompressor()); - if (in.fail()) - { - fprintf(stderr, "\nError: can't decompress complex trait file \"%s\". \n\n ", gwas_file); - exit(1); - } - in.push(dfile); - - string line; - istringstream ins; - - string snp_id; // important - string sig_id; - double prior; - double posterior; - - string delim = "|"; - - double gwas_sum = 0; - int gwas_count = 0; - int format_status = 0; - while (getline(in, line)) - { - - ins.clear(); - ins.str(line); - - if (ins >> snp_id >> sig_id >> posterior) - { - format_status = 1; - if (snp_index.find(snp_id) == snp_index.end()) - { - snp_index[snp_id] = snp_vec.size(); - snp_vec.push_back(snp_id); - } - - if (snp2gwas_locus.find(snp_id) == snp2gwas_locus.end()) - { - snp2gwas_locus[snp_id] = sig_id; - } - else - { - snp2gwas_locus[snp_id] += "_" + sig_id; - } - - if (gwas_sig_index.find(sig_id) == gwas_sig_index.end()) - { - gwas_sig_index[sig_id] = gwas_vec.size(); - sigCluster cluster; - cluster.id = sig_id; - cluster.cpip = 0; - gwas_vec.push_back(cluster); - } - - int index = gwas_sig_index[sig_id]; - gwas_vec[index].cpip += posterior; - gwas_vec[index].snp_vec.push_back(snp_id); - gwas_vec[index].pip_vec.push_back(posterior); - gwas_sum += posterior; - gwas_count++; - } - } - if (format_status == 0) - { - fprintf(stderr, "\nError: unexpected format in complex trait file \"%s\".\n\n", gwas_file); - exit(1); - } - - if (gwas_sum == 0) - { - fprintf(stderr, "\nError: no complex trait associations detected in \"%s\". \n\n", gwas_file); - exit(1); - } - - gwas_pip_vec = vector(snp_vec.size(), 0.0); - - for (int i = 0; i < gwas_vec.size(); i++) - { - for (int j = 0; j < gwas_vec[i].snp_vec.size(); j++) - { - string snp = gwas_vec[i].snp_vec[j]; - gwas_pip_vec[snp_index[snp]] = gwas_vec[i].pip_vec[j]; - } - } - - if (total_snp < snp_vec.size()) - total_snp = snp_vec.size(); - - pi1 = gwas_sum / total_snp; - - fprintf(stderr, "read in %d SNPs (eQTL+gwas), %d GWAS loci, %.1f expected hits\n\n", int(snp_vec.size()), int(gwas_vec.size()), gwas_sum); - // fprintf(stderr, "%d %d %7.3e %f\n", gwas_count, total_snp, pi1, gwas_sum); - P_gwas = gwas_sum / total_snp; - P_eqtl = P_eqtl / total_snp; -} - -void controller::enrich_est() -{ - - const gsl_rng_type *T; - gsl_rng *r; - gsl_rng_env_setup(); - T = gsl_rng_default; - r = gsl_rng_alloc(T); - - vector a0_vec = vector(ImpN, 0.0); - vector v0_vec = vector(ImpN, 0.0); - vector a1_vec = vector(ImpN, 0.0); - vector v1_vec = vector(ImpN, 0.0); - -#pragma omp parallel for num_threads(nthread) - for (int k = 0; k < ImpN; k++) - { - - vector eqtl_sample = vector(snp_vec.size(), 0); - - for (int i = 0; i < eqtl_vec.size(); i++) - { - int rst = eqtl_vec[i].impute_qtn(r); - if (rst >= 0) - { - string snp = eqtl_vec[i].snp_vec[rst]; - eqtl_sample[snp_index[snp]] = 1; - } - } - - vector rst = run_EM(eqtl_sample); -#pragma omp critical - { - a0_vec[k] = rst[0]; - a1_vec[k] = rst[1]; - v0_vec[k] = rst[2]; - v1_vec[k] = rst[3]; - } - fprintf(stderr, "Imputation round %2d is completed\n", k + 1); - } - - a0_est = 0; - a1_est = 0; - - double var0 = 0; - double var1 = 0; - for (int k = 0; k < ImpN; k++) - { - a0_est += a0_vec[k]; - a1_est += a1_vec[k]; - var0 += v0_vec[k]; - var1 += v1_vec[k]; - } - - a0_est = a0_est / ImpN; - a1_est = a1_est / ImpN; - - double bv0 = 0; - double bv1 = 0; - for (int k = 0; k < ImpN; k++) - { - - bv0 += pow(a0_vec[k] - a0_est, 2); - bv1 += pow(a1_vec[k] - a1_est, 2); - } - - bv0 = bv0 / (ImpN - 1); - bv1 = bv1 / (ImpN - 1); - var0 = var0 / ImpN; - var1 = var1 / ImpN; - - double sd0 = sqrt(var0 + bv0 * (ImpN + 1) / ImpN); - double sd1 = sqrt(var1 + bv1 * (ImpN + 1) / ImpN); - - double a1_est_ns = a1_est; - double sd1_ns = sd1; - - // apply shrinkage - if (prior_variance > 0) - { - double post_var = 1.0 / (1.0 / prior_variance + 1 / (sd1 * sd1)); - a1_est = (a1_est_ns * prior_variance) / (prior_variance + sd1_ns * sd1_ns); - sd1 = sqrt(post_var); - } - - a0_est = log(P_gwas / (1 + P_eqtl * exp(a1_est) - P_eqtl - P_gwas)); - - string enrich_file = prefix + string("enloc.enrich.out"); - FILE *fd = fopen(enrich_file.c_str(), "w"); - fprintf(fd, "%25s %7.3f %7s\n", "Intercept", a0_est, "-"); - fprintf(fd, "%25s %7.3f %7.3f\n", "Enrichment (no shrinkage)", a1_est_ns, sd1_ns); - fprintf(fd, "%25s %7.3f %7.3f\n", "Enrichment (w/ shrinkage)", a1_est, sd1); - - double p1 = (1-P_eqtl)* exp(a0_est)/(1+exp(a0_est)); - double p2 = P_eqtl/(1+exp(a0_est+a1_est)); - double p12 = P_eqtl*exp(a0_est+a1_est)/(1+exp(a0_est+a1_est)); - - fprintf(fd,"\n\n## Alternative (coloc) parameterization: p1 = %7.3e, p2 = %7.3e, p12 = %7.3e\n\n",p1,p2,p12); - - fclose(fd); - - set_enrich_params(a0_est, a1_est); - - // pi1_e = exp(a0_est+a1_est)/(1+exp(a0_est + a1_est)); - // pi1_ne = exp(a0_est)/(1+exp(a0_est)); - // printf("%7.3e %7.3e %7.3e\n", pi1_e, pi1_ne, pi1); - - fprintf(stderr, "\nEnrichment analysis is completed\n"); - - gsl_rng_free(r); - return; -} - -void controller::set_enrich_params(double a0, double a1) -{ - - pi1_e = exp(a0 + a1) / (1 + exp(a0 + a1)); - pi1_ne = exp(a0) / (1 + exp(a0)); -} - -void controller::set_enrich_params(double p1, double p2, double p12) -{ - - double a0 = log(p1 / (1 - p1 - p2 - p12)); - double a1 = log(p12 * (1 - p1 - p2 - p12) / (p1 * p2)); - fprintf(stderr, "converting enrichment parameters: \n"); - fprintf(stderr, "%10s %7.3f\n", "Intercept", a0); - fprintf(stderr, "%10s %7.3f\n\n", "Enrichment", a1); - - set_enrich_params(a0, a1); -} - -void controller::compute_coloc_prob() -{ - - fprintf(stderr, "\nComputing colocalization probabilities ... \n\n"); - - string snp_file = prefix + string("enloc.snp.out"); - string sig_file = prefix + string("enloc.sig.out"); - string gen_file = prefix + string("enloc.gene.out"); - - FILE *fd1 = fopen(snp_file.c_str(), "w"); - FILE *fd2 = fopen(sig_file.c_str(), "w"); - FILE *fd3 = fopen(gen_file.c_str(), "w"); - - fprintf(fd1, "Signal\tSNP\tPIP_qtl\tPIP_gwas_marginal\tPIP_gwas_qtl_prior\tSCP\n"); - fprintf(fd2, "Signal\tNum_SNP\tCPIP_qtl\tCPIP_gwas_marginal\tCPIP_gwas_qtl_prior\tRCP\tLCP\n"); - fprintf(fd3, "Gene\t\tGRCP\tGLCP\n"); - - double r_null = pi1 / (1 - pi1); - double r1 = pi1_e / (1 - pi1_e); - double r0 = pi1_ne / (1 - pi1_ne); - - for (int i = 0; i < eqtl_vec.size(); i++) - { - eqtl_vec[i].coloc_prob = 0; - eqtl_vec[i].locus_coloc_prob = 0; - vector gprob_vec_null; - double gprob_null = 0; - vector gbf_vec; - - for (int k = 0; k < eqtl_vec[i].snp_vec.size(); k++) - { - string snp = eqtl_vec[i].snp_vec[k]; - double d = gwas_pip_vec[snp_index[snp]]; - gprob_vec_null.push_back(d); - gprob_null += d; - } - - if (gprob_null > 1 - 1e-5) - { - // renormalize - for (int k = 0; k < eqtl_vec[i].snp_vec.size(); k++) - { - gprob_vec_null[k] = (1 - 1e-5) * (gprob_vec_null[k] / gprob_null); - } - - gprob_null = 1 - 1e-5; - } - - double nc = ((1 - pi1) / pi1) / (1 - gprob_null); - double sum_bf = nc - (1 - pi1) / pi1; - vector bf_vec; - - // for consolidated locus-level colocalization - double locus_gpip = gprob_null; - double locus_epip = 0; - // lcp def done - - for (int k = 0; k < eqtl_vec[i].snp_vec.size(); k++) - { - // lcp comp - locus_epip += eqtl_vec[i].pip_vec[k]; - // lcp comp done - double bf = gprob_vec_null[k] * nc; - bf_vec.push_back(bf); - } - - double gwas_cpip = 0; - double max_scp = 0; - string max_snp; - - for (int k = 0; k < eqtl_vec[i].snp_vec.size(); k++) - { - - string snp = eqtl_vec[i].snp_vec[k]; - - double prob = bf_vec[k] / ((1 - pi1_e) / pi1_e + ((1 - pi1_e) / pi1_e) * (pi1_ne / (1 - pi1_ne)) * (sum_bf - bf_vec[k]) + bf_vec[k]); - // snp level coloc prob - double p_coloc = prob * eqtl_vec[i].pip_vec[k]; - double gprob_e = p_coloc; - eqtl_vec[i].coloc_prob += p_coloc; - eqtl_vec[i].locus_coloc_prob += p_coloc; - - // update overall GWAS association evidence considering informative QTL prior: gprob_e - - // other non-coloc possibilities - // no eqtl, k-th SNP is the gwas hit - prob = bf_vec[k] / ((1 - pi1_ne) / pi1_ne + sum_bf); - gprob_e += prob * (1 - eqtl_vec[i].cpip); - - // j-th SNP is the eQTL, and k-th SNP is the GWAS - for (int j = 0; j < eqtl_vec[i].snp_vec.size(); j++) - { - if (j == k) - continue; - prob = bf_vec[k] / (((1 - pi1_ne) / pi1_ne) + (sum_bf - bf_vec[j]) + (pi1_e / (1 - pi1_e)) * ((1 - pi1_ne) / pi1_ne) * bf_vec[j]); - gprob_e += prob * eqtl_vec[i].pip_vec[j]; - eqtl_vec[i].locus_coloc_prob += prob * eqtl_vec[i].pip_vec[j]; - } - - string locus_id = eqtl_vec[i].id + "(@)" + snp2gwas_locus[snp]; - if (p_coloc >= output_thresh) - fprintf(fd1, "%15s %15s %7.3e %7.3e %7.3e %7.3e\n", locus_id.c_str(), snp.c_str(), eqtl_vec[i].pip_vec[k], gprob_vec_null[k], gprob_e, p_coloc); - gwas_cpip += gprob_e; - if (p_coloc >= max_scp) - { - max_scp = p_coloc; - max_snp = snp; - } - } - - // lcp comp (proposed solution) -- DAP - int np = eqtl_vec[i].snp_vec.size(); - double locus_bf = (1.0 / np) * (locus_gpip / (1 - locus_gpip)) / (pi1 / (1 - pi1)); - double factor = (1 - pi1_ne) * (1 - pi1_e) / ((1 - pi1_ne) * pi1_e + (np - 1) * (1 - pi1_e) * pi1_ne); - double lcp = (locus_bf / (factor + locus_bf)) * locus_epip; - - if (lcp < eqtl_vec[i].coloc_prob) - { - lcp = eqtl_vec[i].coloc_prob; - } - - eqtl_vec[i].locus_coloc_prob = lcp; - - // lcp comp done - - if (eqtl_vec[i].coloc_prob >= output_thresh || eqtl_vec[i].locus_coloc_prob >= output_thresh) - { - string locus_id = eqtl_vec[i].id + "(@)" + snp2gwas_locus[max_snp]; - fprintf(fd2, "%15s %4d %7.3e %7.3e %7.3e %7.3e\t%7.3e\n", locus_id.c_str(), int(eqtl_vec[i].snp_vec.size()), eqtl_vec[i].cpip, gprob_null, gwas_cpip, eqtl_vec[i].coloc_prob, eqtl_vec[i].locus_coloc_prob); - } - - } - - - - // gene-level quantification - map GLCP; - map GRCP; - - for (int i = 0; i < eqtl_vec.size(); i++) - { - string loc_id = eqtl_vec[i].id; - int pos = loc_id.find(":"); - string gene_id = loc_id.substr(0,pos); - if(GLCP.find(gene_id)==GLCP.end()){ - GLCP[gene_id] = 1; - GRCP[gene_id] = 1; - } - - GLCP[gene_id] *= (1-eqtl_vec[i].locus_coloc_prob); - GRCP[gene_id] *= (1-eqtl_vec[i].coloc_prob); - - } - - - - std::map::iterator it = GRCP.begin(); - while (it != GRCP.end()) - { - string gene = it->first; - double v1 = 1 - it->second; - double v2 = 1- GLCP[gene]; - fprintf(fd3, "%s\t\t%7.3e\t%7.3e\n", gene.c_str(), v1, v2); - it++; - } - - fclose(fd1); - fclose(fd2); - fclose(fd3); -} - -vector controller::run_EM(vector &eqtl_sample) -{ - - double a0 = log(pi1 / (1 - pi1)); - double a1 = 0; - double var0; - double var1; - double r1 = exp(a0 + a1); - double r0 = exp(a0); - double r_null = pi1 / (1 - pi1); - - while (1) - { - // E-step - double pseudo_count = 1.0; - double e0g0 = pseudo_count * (1 - P_gwas) * (1 - P_eqtl); - double e0g1 = pseudo_count * (1 - P_eqtl) * P_gwas; - double e1g0 = pseudo_count * (1 - P_gwas) * P_eqtl; - double e1g1 = pseudo_count * P_gwas * P_eqtl; - - for (int i = 0; i < snp_vec.size(); i++) - { - - double val = gwas_pip_vec[i]; - if (val == 1) - val = 1 - 1e-8; - // posterior ratio - val = val / (1 - val); - // val/r_null is marginal likelihood/bayes factor - if (eqtl_sample[i] == 0) - { - val = r0 * (val / r_null); - // updated posterior with current prior given eqtl = 0 - val = val / (1 + val); - e0g1 += val; - e0g0 += 1 - val; - } - - if (eqtl_sample[i] == 1) - { - val = r1 * (val / r_null); - // updated posterior with current prior given eqtl = 1 - val = val / (1 + val); - e1g1 += val; - e1g0 += 1 - val; - } - } - - e0g0 += total_snp - (e0g0 + e0g1 + e1g0 + e1g1); - - double a1_new = log(e1g1 * e0g0 / (e1g0 * e0g1)); - - // printf("EM: %f\t%f\t%f\t%fi\t\t%f\t%f\n", e0g0, e1g1, e1g0, e0g1,a1_new, a1); - if (fabs(a1_new - a1) < 0.01) - { - a1 = a1_new; - var1 = (1.0 / e0g0 + 1.0 / e1g0 + 1.0 / e1g1 + 1.0 / e0g1); - var0 = (1.0 / e0g1 + 1.0 / e0g0); - break; - } - - a1 = a1_new; - a0 = log(e0g1 / e0g0); - // a0 = log((e0g1+1)/(e0g0+1)); - - r0 = exp(a0); - r1 = exp(a0 + a1); - } - vector av; - av.push_back(a0); - av.push_back(a1); - av.push_back(var0); - av.push_back(var1); - return (av); -} - -void controller::set_prefix(char *str) -{ - - if (strlen(str) == 0) - { - prefix = string(""); - } - else - { - prefix = string(str) + string("."); - } -} diff --git a/inst/code/fastenloc_archive/controller.h b/inst/code/fastenloc_archive/controller.h deleted file mode 100644 index 790828d0..00000000 --- a/inst/code/fastenloc_archive/controller.h +++ /dev/null @@ -1,84 +0,0 @@ -using namespace std; - -#include "sigCluster.h" -#include -#include -#include - -class controller { - - private: - - vector eqtl_vec; - vector gwas_vec; - map eqtl_sig_index; - map gwas_sig_index; - - map snp2gwas_locus; - - - map snp_index; - vector snp_vec; - vector gwas_pip_vec; - - string prefix; - - int ImpN; - int nthread; - - int total_snp; - - double pi1; - double pi1_e; - double pi1_ne; - - double a0_est; - double a1_est; - - // for enrichment prior - double prior_variance; - double P_eqtl; - double P_gwas; - - // threshold value to output signal/snp coloc probs - double output_thresh; - - - public: - - void set_imp_num(int imp){ - ImpN = imp; - } - - void set_snp_size(int size){ - total_snp = size; - } - - void set_prior_variance (double pv){ - prior_variance = pv; - } - - void set_thread(int thread){ - nthread = thread; - } - - void set_prefix(char *str); - - void set_enrich_params(double p1, double p2, double p12); - void set_enrich_params(double a0, double a1); - - void load_eqtl(char *eqtl_file, char *tissue); - void load_gwas_torus(char *gwas_file); - - - void set_output_thresh(double value){ - output_thresh = value; - } - - void enrich_est(); - void compute_coloc_prob(); - - private: - - vector run_EM(vector & eqtl_sample); -}; diff --git a/inst/code/fastenloc_archive/main.cc b/inst/code/fastenloc_archive/main.cc deleted file mode 100644 index 75938e5f..00000000 --- a/inst/code/fastenloc_archive/main.cc +++ /dev/null @@ -1,271 +0,0 @@ -#include "controller.h" -#include -#include -#include - -#define LENGTH 1024 -#define UNDEF -99999999 - -int show_banner(){ - - fprintf(stderr, "\t\t==================================================================\n\n"); - fprintf(stderr, "\t\t fastENLOC (v2.0) \n\n"); - fprintf(stderr, "\t\t April, 2022 \n\n"); - fprintf(stderr, "\t\t==================================================================\n\n\n"); - return 1; -} - -int print_usage(){ - - fprintf(stderr, "\nUsage: fastenloc -eqtl eqtl_file -gwas gwas_file [-tissue tissue_name] [-total_variants total_number_of_gwas_variants] [-thread number_of_processing_thread] [-s shrinkage_param] [-prefix output_prefix] \n\n"); - return 1; -} - -int main(int argc, char **argv){ - - - char eqtl_file[LENGTH]; - char gwas_file[LENGTH]; - char tissue[LENGTH]; - char prefix[LENGTH]; - - memset(eqtl_file, 0, LENGTH); - memset(gwas_file, 0, LENGTH); - memset(tissue, 0, LENGTH); - memset(prefix, 0, LENGTH); - - int set_enrich_p = 0; - int set_enrich_a = 0; - - double a0 = UNDEF; - double a1 = UNDEF; - - double p1 = UNDEF; - double p2 = UNDEF; - double p12 = UNDEF; - - double output_thresh = 1e-4; - - int ImpN = 25; - int nthread = 1; - int enrich_est_only = 0; - double shrinkage = -1; - - int total_snp = 0; - int set_warning = 0; - int set_error = 0; - - show_banner(); - - for(int i=1;i0){ - pv = 1/shrinkage; - } - - con.set_prior_variance(pv); - - - - - - - - - - - con.load_eqtl(eqtl_file, tissue); - con.load_gwas_torus(gwas_file); - - - if(a0 != UNDEF && a1 != UNDEF){ - con.set_enrich_params(a0,a1); - }else if(p1 != UNDEF && p2 != UNDEF && p12!= UNDEF){ - con.set_enrich_params(p1,p2,p12); - }else{ - con.enrich_est(); - } - if(!enrich_est_only){ - con.compute_coloc_prob(); - } - - - fprintf(stderr, "\nfastENLOC analysis is completed "); - if(set_warning == 1){ - fprintf(stderr, "with 1 warning"); - } - fprintf(stderr,"\n\n"); - - -} diff --git a/inst/code/fastenloc_archive/sigCluster.cc b/inst/code/fastenloc_archive/sigCluster.cc deleted file mode 100644 index 6ddff73b..00000000 --- a/inst/code/fastenloc_archive/sigCluster.cc +++ /dev/null @@ -1,27 +0,0 @@ -#include "sigCluster.h" -#include - -int sigCluster::impute_qtn(const gsl_rng *r){ - - if(pip_prob==0){ - if(pip_vec.size() == 0) - return -1; - else{ - pip_prob = new double[pip_vec.size()+1]; - for(int i=0;i -#include -#include - -class sigCluster { - - public: - - string gene; - string id; //signal id of the gene - double cpip; - vector pip_vec; - vector snp_vec; - vector coloc_vec; - - double coloc_prob; - double locus_coloc_prob; - - private: - double *pip_prob; - - public: - - sigCluster(){ - pip_prob = 0; - coloc_prob = locus_coloc_prob = cpip = 0; - } - - int impute_qtn(const gsl_rng *r); - -}; diff --git a/inst/code/tensorqtl_postprocessor.R b/inst/code/tensorqtl_postprocessor.R deleted file mode 100644 index 1ab3a4a6..00000000 --- a/inst/code/tensorqtl_postprocessor.R +++ /dev/null @@ -1,1512 +0,0 @@ -suppressPackageStartupMessages({ - library(qvalue) - library(dplyr) - library(tidyr) - library(readr) - library(arrow) -}) - -# Utility function for NULL coalescing -`%||%` <- function(a, b) if (is.null(a)) b else a - -# Standardize chromosome format - VECTORIZED VERSION -standardize_chrom <- function(chrom_vector) { - chrom_vector <- as.character(chrom_vector) - # Vectorized operation without if statement - needs_prefix <- !grepl("^chr", chrom_vector) - chrom_vector[needs_prefix] <- paste0("chr", chrom_vector[needs_prefix]) - return(chrom_vector) -} - -safe_qvalue <- function(p, ...) { - # First try default settings - tryCatch( - { - return(qvalue(p, ...)) - }, - error = function(e) { - warning(e$message) - # For "missing or infinite values" error - if (grepl("missing or infinite", e$message)) { - return(qvalue(p, lambda = 0, ...)) - } - # For "pi0 <= 0" error - else if (grepl("pi0 <= 0", e$message)) { - max_p <- max(p) - lambda_seq <- seq(0, min(0.9, max_p * 0.95), length.out = 10) - return(qvalue(p, lambda = lambda_seq, pi0.method = "bootstrap", ...)) - } - # If all else fails - else { - q <- p.adjust(p, method = "BH") - result <- list(call = match.call(), pi0 = 1, qvalues = q, pvalues = p) - class(result) <- "qvalue" - return(result) - } - } - ) -} - -# Parse additional p-value columns parameter -parse_additional_pvalue_cols <- function(additional_pvalue_cols_str) { - if (is.null(additional_pvalue_cols_str) || additional_pvalue_cols_str == "" || additional_pvalue_cols_str == "NULL") { - return(character(0)) - } - # Split by comma and trim whitespace - cols <- trimws(strsplit(additional_pvalue_cols_str, ",")[[1]]) - return(cols[cols != ""]) -} - -# Check if qvalue column exists in file -check_qvalue_exists <- function(file_path, qvalue_pattern) { - if (grepl("\\.parquet$", file_path)) { - cols <- names(read_parquet(file_path, n_max = 1)) - } else { - if (grepl("\\.(gz|bz2|xz)$", file_path)) { - header <- system(paste0("zcat ", shQuote(file_path), " | head -1"), intern = TRUE) - } else { - header <- system(paste0("head -1 ", shQuote(file_path)), intern = TRUE) - } - cols <- strsplit(header, "\t")[[1]] - } - - q_cols <- grep(qvalue_pattern, cols, value = TRUE) - return(length(q_cols) > 0) -} - -# Extract chromosome and position from variant_id if needed -extract_chrom_pos_from_variant_id <- function(data) { - if ("chrom" %in% names(data)) { - message("Column 'chrom' already exists, no extraction needed") - return(data) - } - - if (!"variant_id" %in% names(data)) { - stop("Neither 'chrom' nor 'variant_id' column found in data") - } - - message("Extracting 'chrom' and 'pos' from 'variant_id' column") - - # Extract chrom and pos from variant_id (format: chr1:14677_G_A) - data <- data %>% - mutate( - chrom = gsub("^(chr[^:]+):.*$", "\\1", variant_id), - pos = as.integer(gsub("^[^:]+:([0-9]+)_.*$", "\\1", variant_id)) - ) - - # Check if extraction was successful - if (any(is.na(data$pos)) || any(data$chrom == data$variant_id)) { - warning("Some variant_id entries could not be parsed. Check format: expected 'chrX:position_ref_alt'") - # Show examples of problematic entries - problematic <- data$variant_id[data$chrom == data$variant_id | is.na(data$pos)] - if (length(problematic) > 0) { - message("Examples of problematic variant_id entries:") - print(head(problematic, 5)) - } - } - - message(sprintf("Successfully extracted chrom and pos for %d variants", nrow(data))) - return(data) -} - -# Compute qvalues for molecular traits -compute_and_save_qvalues <- function(params) { - setwd(params$workdir) - message("Computing q-values for QTL files...") - - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - - # Get all QTL files - qtl_files <- list.files(pattern = params$qtl_pattern, full.names = TRUE) - if (length(qtl_files) == 0) { - message("No QTL files found matching pattern") - return(list(files = qtl_files, data_list = list(), need_qvalue_computation = FALSE)) - } - - # Check if qvalue column exists in first file - qvalue_exists <- check_qvalue_exists(qtl_files[1], params$qvalue_pattern) - - if (qvalue_exists) { - message("Q-value column already exists, skipping q-value computation") - return(list(files = qtl_files, data_list = list(), need_qvalue_computation = FALSE)) - } - - message("Q-value column not found, computing q-values...") - - # Parse additional p-value columns - additional_pvalue_cols <- parse_additional_pvalue_cols(params$additional_pvalue_cols) - - # Get column info from first file - column_info <- extract_column_names(qtl_files[1], params$pvalue_pattern, params$qvalue_pattern) - main_pvalue_col <- column_info$p_col - main_qvalue_col <- column_info$q_col - - message(sprintf("Processing %d files with main p-value column: %s -> %s", - length(qtl_files), main_pvalue_col, main_qvalue_col)) - - if (length(additional_pvalue_cols) > 0) { - additional_qvalue_cols <- gsub("^pval", "qval", additional_pvalue_cols) - message(sprintf("Additional p-value columns: %s -> %s", - paste(additional_pvalue_cols, collapse = ", "), - paste(additional_qvalue_cols, collapse = ", "))) - } - - # Determine if we need p-value filtering - apply_pvalue_filter <- params$pvalue_cutoff < 1 - if (apply_pvalue_filter) { - message(sprintf("Will apply p-value filter < %g during processing to save memory", params$pvalue_cutoff)) - } - - # Process each file: read -> compute qvalue -> save complete -> filter -> store filtered - filtered_data_list <- list() - - for (i in seq_along(qtl_files)) { - file_path <- qtl_files[i] - message(sprintf("Processing file %d/%d: %s", i, length(qtl_files), basename(file_path))) - - # Step 1: Read file - if (grepl("\\.parquet$", file_path)) { - data <- read_parquet(file_path) - } else { - is_compressed <- grepl("\\.(gz|bz2|xz)$", file_path) - if (is_compressed) { - data <- data.table::fread(cmd = paste("zcat", shQuote(file_path))) - } else { - data <- data.table::fread(file_path) - } - } - - # Step 2: Compute q-values for each molecular trait - data_with_qvalues <- data %>% - # Extract chrom/pos from variant_id if needed - extract_chrom_pos_from_variant_id() %>% - group_by(!!sym(molecular_id_col)) %>% - do({ - trait_data <- . - - # Compute q-value for main p-value column - if (main_pvalue_col %in% names(trait_data)) { - trait_data[[main_qvalue_col]] <- safe_qvalue(trait_data[[main_pvalue_col]])$qvalues - } - - # Compute q-values for additional p-value columns - for (pval_col in additional_pvalue_cols) { - if (pval_col %in% names(trait_data)) { - # More flexible column name conversion: pval_* -> qval_* - qval_col <- gsub("^pval", "qval", pval_col) - trait_data[[qval_col]] <- safe_qvalue(trait_data[[pval_col]])$qvalues - } else { - warning(sprintf("P-value column '%s' not found in file %s", pval_col, basename(file_path))) - } - } - - trait_data - }) %>% - ungroup() - - # Print completion message once per file - if (length(additional_pvalue_cols) > 0) { - for (pval_col in additional_pvalue_cols) { - qval_col <- gsub("^pval", "qval", pval_col) - message(sprintf("Computed %s -> %s for %s", pval_col, qval_col, basename(file_path))) - } - } - - # Step 3: Save complete data with qvalues (always as .tsv.gz) - message(sprintf("Saving computed q-values for file: %s", basename(file_path))) - - # Always save as .tsv.gz regardless of input format - if (grepl("\\.parquet$", file_path)) { - output_file <- sub("\\.parquet$", ".qvalue_computed.tsv.gz", file_path) - } else if (grepl("\\.gz$", file_path)) { - output_file <- sub("\\.gz$", ".qvalue_computed.tsv.gz", file_path) - } else { - output_file <- sub("\\.(tsv|txt)$", ".qvalue_computed.tsv.gz", file_path) - } - - write_delim(data_with_qvalues, gzfile(output_file), delim = "\t") - message(sprintf("Saved complete q-value computed file: %s", basename(output_file))) - - # Step 4: Apply p-value filtering immediately to save memory - if (apply_pvalue_filter) { - pre_filter_rows <- nrow(data_with_qvalues) - filtered_data <- data_with_qvalues %>% - filter(!!sym(main_pvalue_col) < params$pvalue_cutoff) - post_filter_rows <- nrow(filtered_data) - message(sprintf("Applied p-value filter: %d -> %d rows", pre_filter_rows, post_filter_rows)) - - # Store the filtered data for rbind - filtered_data_list[[i]] <- filtered_data - } else { - # No filtering needed, store all data - filtered_data_list[[i]] <- data_with_qvalues - } - - # Step 5: Clean up memory - rm(data, data_with_qvalues) - if (apply_pvalue_filter && exists("filtered_data")) { - rm(filtered_data) - } - gc() # Force garbage collection to free memory - } - - return(list(files = qtl_files, data_list = filtered_data_list, need_qvalue_computation = TRUE)) -} - -find_common_prefix <- function(files) { - if (length(files) == 0) { - return("") - } - if (length(files) == 1) { - return(files) - } - - # Extract basenames if full paths were provided - filenames <- basename(files) - - # Split by dots - parts_list <- strsplit(filenames, "\\.") - - # Find minimum number of parts - min_parts <- min(sapply(parts_list, length)) - - # Compare parts position by position - common_parts <- character(0) - for (i in 1:min_parts) { - current_parts <- sapply(parts_list, `[`, i) - if (length(unique(current_parts)) == 1) { - common_parts <- c(common_parts, current_parts[1]) - } else { - break - } - } - - # If no common parts found, try alternative approach - # Look for common prefix before chromosome pattern - if (length(common_parts) == 0) { - # Try to find common prefix before "chr" pattern - chr_pattern <- "_chr\\d+|chr\\d+" - - # For each file, find position of chromosome pattern - chr_positions <- sapply(filenames, function(f) { - match_pos <- regexpr(chr_pattern, f) - if (match_pos > 0) { - return(match_pos - 1) # Position just before the match - } else { - return(nchar(f)) # If no chr pattern, use full length - } - }) - - # If all files have chr pattern at roughly same position - if (all(chr_positions > 0)) { - min_pos <- min(chr_positions) - # Extract common prefix up to the chromosome part - prefixes <- sapply(filenames, function(f) substr(f, 1, min_pos)) - - # Find the longest common prefix among these - if (length(unique(prefixes)) == 1) { - # All prefixes are the same - common_prefix <- prefixes[1] - } else { - # Find character-by-character common prefix - min_len <- min(nchar(prefixes)) - common_prefix <- "" - for (pos in 1:min_len) { - chars <- sapply(prefixes, function(p) substr(p, pos, pos)) - if (length(unique(chars)) == 1) { - common_prefix <- paste0(common_prefix, chars[1]) - } else { - break - } - } - } - - # Remove trailing underscores or dots - common_prefix <- sub("[._]+$", "", common_prefix) - - if (nchar(common_prefix) > 0) { - return(common_prefix) - } - } - } - - # Return the joined common parts (original logic) - if (length(common_parts) == 0) { - return("") - } - return(paste(common_parts, collapse = ".")) -} - -read_and_combine_files <- function(files, ...) { - if (length(files) == 0) stop("No files provided") - - # Check file existence - missing <- files[!file.exists(files)] - if (length(missing) > 0) stop("Missing files: ", paste(missing, collapse = ", ")) - - # Determine file types - is_compressed <- grepl("\\.(gz|bz2|xz)$", files) - is_parquet <- grepl("\\.parquet$", files) - - # Load first file - if (is_parquet[1]) { - data <- read_parquet(files[1]) - } else if (is_compressed[1]) { - data <- data.table::fread(cmd = paste("zcat", shQuote(files[1])), ...) - } else { - data <- data.table::fread(files[1], ...) - } - - # Load remaining files and append - if (length(files) > 1) { - for (i in 2:length(files)) { - if (is_parquet[i]) { - next_data <- read_parquet(files[i]) - } else if (is_compressed[i]) { - next_data <- data.table::fread( - cmd = paste("zcat", shQuote(files[i])), - skip = 1, header = FALSE, ... - ) - # Set column names to match first file - data.table::setnames(next_data, names(data)) - } else { - next_data <- data.table::fread(files[i], skip = 1, header = FALSE, ...) - # Set column names to match first file - data.table::setnames(next_data, names(data)) - } - - # Append using rbindlist (faster than rbind) - data <- data.table::rbindlist(list(data, next_data), use.names = TRUE, fill = TRUE) - } - } - - return(data) -} - -# =================================== -# Data Loaders -# =================================== -load_regional_data <- function(params) { - setwd(params$workdir) - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - - # Load permutation-based regional files - regional_files <- vector() - if (!is.null(params$regional_pattern)) { - regional_files <- list.files(pattern = params$regional_pattern, full.names = TRUE) - } - data <- NULL - has_permutation <- FALSE - n_var_col <- NULL - - if (length(regional_files) > 0) { - data <- read_and_combine_files(regional_files) %>% - extract_chrom_pos_from_variant_id() %>% - { - if ("chrom" %in% colnames(.)) mutate(., chrom = standardize_chrom(chrom)) else . - } - has_emt_n_var <- any(grepl("tests_emt", colnames(data))) - # eigenMT test as number of effective variants - if (has_emt_n_var) { - data <- data %>% - rename_with(~molecular_id_col, matches("phenotype_id")) - n_var_col <- "tests_emt" - has_permutation <- FALSE - message("Found 'tests_emt' column in regional data, converting to n_variants") - } else { - n_var_col <- "n_variants" - has_permutation <- TRUE - } - } - - return(list( - regional_summary = data, - regional_data_files = regional_files, - has_permutation = has_permutation, - n_var_col = n_var_col - )) -} - -extract_column_names <- function(file_path, pvalue_pattern = "pvalue", qvalue_pattern = "qvalue") { - if (grepl("\\.parquet$", file_path)) { - # For parquet files, read column names directly - cols <- names(read_parquet(file_path, n_max = 1)) - } else { - # For text files, use original method - if (grepl("\\.(gz|bz2|xz)$", file_path)) { - header <- system(paste0("zcat ", shQuote(file_path), " | head -1"), intern = TRUE) - } else { - header <- system(paste0("head -1 ", shQuote(file_path)), intern = TRUE) - } - cols <- strsplit(header, "\t")[[1]] - } - - column_info <- list( - all_columns = cols - ) - - p_cols <- grep(pvalue_pattern, cols, value = TRUE) - if (length(p_cols) > 1) stop(sprintf("Multiple p-value columns detected using input pattern %s", pvalue_pattern)) - column_info$p_col <- p_cols[1] - if (is.na(column_info$p_col)) stop(sprintf("No p-value columns detected using input pattern %s", pvalue_pattern)) - q_cols <- grep(qvalue_pattern, cols, value = TRUE) - if (length(q_cols) > 1) stop(sprintf("Multiple q-value columns detected using input pattern %s", qvalue_pattern)) - column_info$q_col <- q_cols[1] - if (is.na(column_info$q_col)) column_info$q_col <- qvalue_pattern # if q-value column not detected it is okay. We can compute it later - - column_info$p_idx <- which(cols == column_info$p_col) - if (length(column_info$p_idx) == 0) { - stop(sprintf("P-value column '%s' not found", column_info$p_col)) - } - - return(column_info) -} - -# Gene coordinate data loader -load_gene_coordinates <- function(params) { - gene_coords <- data.table::fread(params$gene_coordinates) %>% mutate(chr = standardize_chrom(chr)) - message(sprintf("Loaded gene coordinates with %d entries", nrow(gene_coords))) - return(gene_coords) -} - -# Calculate feature positions for cis-window filtering -calculate_feature_positions <- function(qtl_data, cis_window, gene_coords, molecular_id_col = "molecular_trait_object_id", start_distance_col = "start_distance", end_distance_col = "end_distance") { - # Extract ENSEMBL IDs from molecular_trait_object_id - extract_ensembl <- function(ids) { - pattern <- "^.*?(ENSG\\d+).*$" - ensembl_ids <- gsub(pattern, "\\1", ids) - not_matched <- ensembl_ids == ids & !grepl("ENSG\\d+", ids) - if (any(not_matched)) { - ensembl_ids[not_matched] <- NA - } - return(ensembl_ids) - } - - unique_traits <- qtl_data %>% - select(!!sym(molecular_id_col), chrom) %>% - distinct() %>% - mutate( - ensembl_id = extract_ensembl(.data[[molecular_id_col]]) - ) - - # Join with lookup to get TSS/TES positions - merged_traits <- unique_traits %>% - left_join( - gene_coords %>% - select(chrom = chr, gene_id, gene_start = start, gene_end = end), - by = c("ensembl_id" = "gene_id", "chrom" = "chrom") - ) - - # For unmapped genes, calculate approximate positions from variant data - if (sum(is.na(merged_traits$gene_start)) > 0) { - fallback_positions <- qtl_data %>% - filter(!!sym(molecular_id_col) %in% - merged_traits[[molecular_id_col]][is.na(merged_traits$gene_start)]) %>% - group_by(!!sym(molecular_id_col), chrom) %>% - summarize( - approx_tss = first(pos) - first(!!sym(start_distance_col)), - approx_tes = first(pos) - first(!!sym(end_distance_col)), - .groups = "drop" - ) - - by_cols <- setNames(c(molecular_id_col, "chrom"), c(molecular_id_col, "chrom")) - merged_traits <- merged_traits %>% - left_join(fallback_positions, by = by_cols) %>% - mutate( - feature_tss = coalesce(gene_start, approx_tss), - feature_tes = coalesce(gene_end, approx_tes) - ) - } else { - merged_traits <- merged_traits %>% - mutate( - feature_tss = gene_start, - feature_tes = gene_end - ) - } - - # Add cis window range - feature_positions <- merged_traits %>% - mutate( - cis_start = feature_tss - cis_window, - cis_end = feature_tes + cis_window - ) %>% - select(!!sym(molecular_id_col), chrom, feature_tss, feature_tes, cis_start, cis_end) - - return(feature_positions) -} - -calculate_filtered_variant_counts <- function(filename, params, gene_coords) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - message(sprintf("Counting per event variants in %s", basename(filename))) - all_cols <- extract_column_names(filename, params$pvalue_pattern, params$qvalue_pattern)$all_columns - required_cols <- c(molecular_id_col, "chrom", "pos", params$af_col, params$start_distance_col, params$end_distance_col) - col_indices <- sapply(required_cols, function(col) which(all_cols == col)) - if (any(sapply(col_indices, length) == 0)) { - stop(sprintf("Required columns missing in file: %s", filename)) - } - awk_cols <- paste(paste0("$", col_indices), collapse = ", ") - cmd <- sprintf( - "zcat %s | awk 'NR==1 {print \"%s\"} NR>1 {print %s}' OFS='\\t'", - shQuote(filename), paste(required_cols, collapse = "\t"), awk_cols - ) - message("Extracting minimal columns from file...") - qtl_data <- data.table::fread(cmd = cmd) %>% - extract_chrom_pos_from_variant_id() %>% - mutate(chrom = standardize_chrom(chrom)) - trait_chrom <- qtl_data %>% - group_by(!!sym(molecular_id_col)) %>% - summarize(chrom = first(chrom)) - original_counts <- qtl_data %>% - group_by(!!sym(molecular_id_col)) %>% - summarize(n_variants_original = n()) - - # NEW: Check if cis_window is 0 to skip cis-window filtering - if (params$cis_window == 0) { - message("cis_window is 0, skipping cis-window filtering, only applying MAF filter...") - - # Apply only MAF filtering - filtered_data <- qtl_data %>% - filter(pmin(!!sym(params$af_col), 1 - !!sym(params$af_col)) > params$maf_cutoff) - - } else { - # Original logic: apply both MAF and cis-window filtering - message("Calculating feature positions and cis windows...") - feature_positions <- calculate_feature_positions( - qtl_data, - params$cis_window, - gene_coords, - molecular_id_col, - params$start_distance_col, - params$end_distance_col - ) - - message("Applying MAF and cis-window filters...") - filtered_data <- qtl_data %>% - left_join( - feature_positions %>% select(!!sym(molecular_id_col), cis_start, cis_end), - by = molecular_id_col - ) %>% - filter( - pmin(!!sym(params$af_col), 1 - !!sym(params$af_col)) > params$maf_cutoff, - pos >= cis_start & pos <= cis_end - ) - } - - # Count filtered variants - filtered_counts <- filtered_data %>% - group_by(!!sym(molecular_id_col)) %>% - summarize(n_variants_filtered = n()) - - # Combine results - results <- trait_chrom %>% - left_join(original_counts, by = molecular_id_col) %>% - left_join(filtered_counts, by = molecular_id_col) %>% - mutate(n_variants_filtered = ifelse(is.na(n_variants_filtered), 0, n_variants_filtered)) %>% - rename(n_variants = n_variants_original) %>% - select(chrom, !!sym(molecular_id_col), n_variants, n_variants_filtered) - - message(sprintf("Processed %d traits in %s", nrow(results), basename(filename))) - return(results) -} - -load_n_variants_data <- function(params, gene_coords) { - setwd(params$workdir) - if (is.null(params$qtl_pattern)) { - stop("params$qtl_pattern must be provided") - } - - if (is.null(params$n_variants_suffix)) { - stop("params$n_variants_suffix must be provided") - } - qtl_files <- list.files(pattern = params$qtl_pattern, full.names = TRUE) - # Create corresponding n_variants filenames by replacing the pattern - n_variants_files <- vector("character", length(qtl_files)) - for (i in seq_along(qtl_files)) { - # Extract base name by removing the pattern (removing $ from pattern) - cleaned_pattern <- sub("\\$$", "", params$qtl_pattern) # Remove $ from end if present - cleaned_pattern <- sub("\\*", "", cleaned_pattern) # Remove * from beginning - base_name <- sub(cleaned_pattern, "", qtl_files[i]) - n_variants_suffix <- sub("\\*", "", params$n_variants_suffix) - n_variants_suffix <- sub("\\$$", "", n_variants_suffix) - - # MODIFIED: Handle cis_window = 0 case differently in filename generation - if (params$cis_window == 0) { - # When cis_window is 0, don't include window information in filename - n_variants_suffix <- sprintf( - "maf_%s_%s", - params$maf_cutoff, - n_variants_suffix - ) - } else { - # Original logic: include window information - n_variants_suffix <- sprintf( - "maf_%s_window_%s_%s", - params$maf_cutoff, - format(params$cis_window, scientific = FALSE), - n_variants_suffix - ) - } - - n_variants_files[i] <- paste0(base_name, ".", n_variants_suffix) - } - - # Check if each n_variants file exists, if not, calculate it - for (i in seq_along(qtl_files)) { - qtl_file <- qtl_files[i] - n_variants_file <- n_variants_files[i] - - if (!file.exists(n_variants_file)) { - message(sprintf("Calculating n_variants for %s", qtl_file)) - n_variants <- calculate_filtered_variant_counts(qtl_file, params, gene_coords) - write.table(n_variants, - file = gzfile(n_variants_file), - quote = FALSE, sep = "\t", row.names = FALSE - ) - } - } - - n_variants_data <- NULL - if (length(n_variants_files) > 0) { - message("Loading n_variants count data...") - n_variants_data <- read_and_combine_files(n_variants_files) %>% - extract_chrom_pos_from_variant_id() %>% - mutate(chrom = standardize_chrom(chrom)) - } - - return(n_variants_data) -} - -load_qtl_data <- function(params, load_n_variants = FALSE) { - setwd(params$workdir) - message('workdir is ', getwd()) - gene_coords <- load_gene_coordinates(params) - - # Compute q-values first if qvalue column doesn't exist - qvalue_result <- compute_and_save_qvalues(params) - files <- qvalue_result$files - - if (length(files) == 0) { - stop("No pair files found") - } - - # Get column names - column_info <- extract_column_names(files[1], params$pvalue_pattern, params$qvalue_pattern) - - # Decide whether to use computed data or read from files - if (qvalue_result$need_qvalue_computation) { - message("Using pre-computed and pre-filtered q-value data") - # Combine all computed and filtered data - data <- data.table::rbindlist(qvalue_result$data_list, use.names = TRUE, fill = TRUE) - - # Extract chrom/pos from variant_id if needed, then standardize - data <- data %>% - extract_chrom_pos_from_variant_id() %>% - mutate(chrom = standardize_chrom(chrom)) - - message(sprintf("Combined data from %d files: %d total rows", - length(qvalue_result$data_list), nrow(data))) - } else { - # Read from original files - # Only filter if pvalue_cutoff is less than 1 - filter_by_p <- params$pvalue_cutoff < 1 - - if (filter_by_p) { - # Filter rows with p-value < threshold for efficiency - files_str <- paste(shQuote(files), collapse = " ") - awk_cmd <- sprintf( - "awk 'NR==1 {print; next} $%d < %s'", - column_info$p_idx, params$pvalue_cutoff - ) - cmd <- sprintf("zcat %s | %s", files_str, awk_cmd) - - message(sprintf("Only loading QTL data with p-value < %g", params$pvalue_cutoff)) - data <- data.table::fread(cmd = cmd) %>% - extract_chrom_pos_from_variant_id() %>% - mutate(chrom = standardize_chrom(chrom)) - } else { - # Load all data (may be huge) - message("Loading all pair data (no p-value filtering)") - data <- read_and_combine_files(files) %>% - extract_chrom_pos_from_variant_id() %>% - mutate(chrom = standardize_chrom(chrom)) - } - } - - # Load n_variants data if requested - n_variants_data <- NULL - if (load_n_variants) { - n_variants_data <- load_n_variants_data(params, gene_coords) - } - - return(list( - data = data, - file_prefix = find_common_prefix(files), - gene_coords = gene_coords, - qtl_files = files, - column_info = column_info, - n_variants_data = n_variants_data - )) -} - -annotate_qtl_with_regional <- function(qtl_data, regional_data, n_variants_data = NULL, use_filtered = FALSE, molecular_id_col = "molecular_trait_object_id") { - if (nrow(qtl_data) == 0) { - # Return empty dataframe with n_variants column - return(qtl_data %>% mutate(n_variants = integer(0))) - } - - # First priority: If use_filtered is TRUE and n_variants_filtered exists in n_variants_data - if (use_filtered && !is.null(n_variants_data) && "n_variants_filtered" %in% names(n_variants_data)) { - n_variants_info <- n_variants_data %>% - select(!!sym(molecular_id_col), n_variants = n_variants_filtered) %>% - distinct() - # Second priority: Use regional_data$regional_summary if available - } else if (!is.null(regional_data$regional_summary)) { - n_variants_info <- regional_data$regional_summary %>% - select(!!sym(molecular_id_col), n_variants = !!sym(regional_data$n_var_col)) %>% - distinct() - # Third priority: Fallback to n_variants in n_variants_data - } else if (!is.null(n_variants_data)) { - n_variants_info <- n_variants_data %>% - select(!!sym(molecular_id_col), n_variants = n_variants) %>% - distinct() - # No n_variants information available - } else { - stop("No n_variants data found. Using counts from data which can be biased if only loading partial QTL data eg with nominal pvalue_cutoff < 1") - } - - # Join to add n_variants - if ("n_variants" %in% colnames(qtl_data)) { - qtl_data <- qtl_data %>% - select(-n_variants) - } - annotated_data <- qtl_data %>% - left_join(n_variants_info, by = molecular_id_col) - - return(annotated_data) -} - -prepare_local_qtl_data <- function(qtl_data, regional_data, params, should_filter = TRUE) { - original_data <- NULL - filtered_data <- NULL - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - - if (should_filter) { - # Check if cis_window is 0 to skip cis-window filtering - if (params$cis_window == 0) { - message("cis_window is 0, applying only MAF filtering...") - # Apply only MAF filtering when cis_window is 0 - filtered_data <- qtl_data$data %>% - filter(pmin(!!sym(params$af_col), 1 - !!sym(params$af_col)) > params$maf_cutoff) - } else { - # Original logic: apply both cis-window and MAF filtering - feature_positions <- calculate_feature_positions(qtl_data$data, params$cis_window, qtl_data$gene_coords, molecular_id_col, params$start_distance_col, params$end_distance_col) - filtered_data <- qtl_data$data %>% - left_join( - feature_positions %>% select(!!sym(molecular_id_col), cis_start, cis_end), - by = molecular_id_col - ) %>% - filter(pmin(!!sym(params$af_col), 1 - !!sym(params$af_col)) > params$maf_cutoff) %>% - filter(pos >= cis_start & pos <= cis_end) - } - - # Check if filtered data has rows - if (nrow(filtered_data) == 0) { - message("Warning: Filtered data has 0 rows after filtering") - # Return empty dataframe with appropriate columns - return(list( - original_data = original_data, - filtered_data = filtered_data %>% mutate(n_variants = integer(0)) - )) - } - filtered_data <- annotate_qtl_with_regional(filtered_data, regional_data, n_variants_data = qtl_data$n_variants_data, use_filtered = TRUE, molecular_id_col = molecular_id_col) - } else { - # Annotate data with n_variants - original_data <- annotate_qtl_with_regional(qtl_data$data, regional_data, n_variants_data = qtl_data$n_variants_data, use_filtered = FALSE, molecular_id_col = molecular_id_col) - } - - if (!is.null(original_data)) { - avg_variants <- original_data %>% - group_by(!!sym(molecular_id_col)) %>% - slice(1) %>% - ungroup() %>% - summarize(avg = mean(n_variants)) %>% - pull(avg) - message( - "Original data: ", nrow(original_data), " rows (avg n_variants per event: ", - round(avg_variants, 0), ")" - ) - } - - if (!is.null(filtered_data)) { - avg_variants <- filtered_data %>% - group_by(!!sym(molecular_id_col)) %>% - slice(1) %>% - ungroup() %>% - summarize(avg = mean(n_variants)) %>% - pull(avg) - message( - "Filtered data: ", nrow(filtered_data), " rows (avg n_variants per event: ", - round(avg_variants, 0), ")" - ) - } - - return(list( - original_data = original_data, - filtered_data = filtered_data - )) -} - -############################################ -# Local Adjustment (Step 1) -############################################ - -permutation_local_adjustment <- function(data, params) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - message("Loading permutation-based local adjustment") - reg_data <- data$regional_data$regional_summary - if (!("p_perm" %in% colnames(reg_data)) && !("p_beta" %in% colnames(reg_data))) { - stop("Permutation local adjustment requires p_perm or p_beta columns in regional data") - } - - event_level_pvalues <- reg_data %>% - select(!!sym(molecular_id_col)) %>% - distinct() - for (col in c("p_perm", "p_beta")) { - if (col %in% colnames(reg_data)) { - event_level_pvalues[[col]] <- reg_data[[col]] - } - } - - data$event_level_pvalues <- event_level_pvalues - data$local_adjustment_info <- list( - method = "permutation", - p_value_columns = c( - if ("p_perm" %in% colnames(event_level_pvalues)) "p_perm", - if ("p_beta" %in% colnames(event_level_pvalues)) "p_beta" - ), - is_filtered = FALSE - ) - return(data) -} - -bonferroni_local_adjustment <- function(data, params, should_filter = FALSE) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - should_filter <- (params$maf_cutoff > 0 || params$cis_window > 0) && should_filter - message(sprintf( - "Applying Bonferroni local adjustment (filter applied: %s)...", - ifelse(should_filter, "Yes", "No") - )) - - p_col <- data$qtl_data$column_info$p_col - qtl_data_updated <- prepare_local_qtl_data( - data$qtl_data, - data$regional_data, - params, - should_filter - ) - - if (should_filter) { - if (is.null(qtl_data_updated$filtered_data) || nrow(qtl_data_updated$filtered_data) == 0) { - message("No data remains after filtering. Returning empty result.") - # Create empty event level p-values - event_level_pvalues <- data.frame( - setNames(list(character(0), numeric(0)), c(molecular_id_col, "p_bonferroni_min")) - ) - - result <- data - result$qtl_data$data <- data.frame() - result$event_level_pvalues <- event_level_pvalues - result$local_adjustment_info <- list( - method = "bonferroni", - p_value_columns = "p_bonferroni_min", - is_filtered = should_filter - ) - return(result) - } - - adjusted_qtl_data <- qtl_data_updated$filtered_data %>% - mutate(p_bonferroni_adj = pmin(1, !!sym(p_col) * n_variants)) - } else { - adjusted_qtl_data <- qtl_data_updated$original_data %>% - mutate(p_bonferroni_adj = pmin(1, !!sym(p_col) * n_variants)) - } - - # Calculate gene-level p-values (min p-value per gene) - event_level_pvalues <- adjusted_qtl_data %>% - group_by(!!sym(molecular_id_col)) %>% - summarize(p_bonferroni_min = min(p_bonferroni_adj)) %>% - ungroup() - - result <- data - result$qtl_data$data <- adjusted_qtl_data - result$event_level_pvalues <- event_level_pvalues - result$local_adjustment_info <- list( - method = "bonferroni", - p_value_columns = "p_bonferroni_min", - is_filtered = should_filter - ) - return(result) -} - -############################################ -# Global Adjustment (Step 2) -############################################ -perform_global_adjustment <- function(data, params) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - message("Applying both FDR and qvalue global adjustments...") - - if (is.null(data$event_level_pvalues) || is.null(data$local_adjustment_info)) { - stop("Cannot perform global adjustment: no event-level p-values found") - } - - # Handle empty event_level_pvalues - if (nrow(data$event_level_pvalues) == 0) { - message("No events to adjust. Returning empty result.") - - result <- data - if (is.null(result$regional_data)) { - result$regional_data <- list() - } - - result$regional_data$regional_summary <- data.frame() - result$global_adjustment_info <- list( - event_adjusted = data.frame(), - local_method = result$local_adjustment_info$method, - p_value_columns = character(0), - fdr_columns = character(0), - q_columns = character(0), - statistics = list() - ) - - return(result) - } - - p_columns <- data$local_adjustment_info$p_value_columns - event_adjusted <- data.frame(setNames(list(data$event_level_pvalues[[molecular_id_col]]), molecular_id_col)) - fdr_columns <- c() - q_columns <- c() - - statistics <- list() - - for (p_col in p_columns) { - # First add the original p-value column - event_adjusted[[p_col]] <- data$event_level_pvalues[[p_col]] - - # Apply FDR adjustment (Benjamini-Hochberg) - fdr_col <- sub("^p_", "fdr_", p_col) - event_adjusted[[fdr_col]] <- p.adjust(data$event_level_pvalues[[p_col]], method = "fdr") - fdr_columns <- c(fdr_columns, fdr_col) - - # Apply qvalue adjustment (Storey's q-value) - q_col <- sub("^p_", "q_", p_col) - event_adjusted[[q_col]] <- safe_qvalue(data$event_level_pvalues[[p_col]])$qvalues - q_columns <- c(q_columns, q_col) - - # Collect statistics for summary - for (threshold in sort(unique(c(0.05, 0.01, params$fdr_threshold)), decreasing = TRUE)) { - for (adj_col in c(fdr_col, q_col)) { - stat_name <- sprintf("%s_%.2f", adj_col, threshold) - statistics[[stat_name]] <- sum(event_adjusted[[adj_col]] < threshold, na.rm = TRUE) - } - } - } - - result <- data # Copy input data to modify and carry over - all_adjustment_cols <- c(fdr_columns, q_columns) - if (is.null(result$regional_data)) { - result$regional_data <- list() - } - - if (!is.null(result$regional_data$regional_summary)) { - # If regional_summary exists, update it with the adjustments - result$regional_data$regional_summary <- result$regional_data$regional_summary %>% - left_join(event_adjusted, by = molecular_id_col, suffix = c("", ".new")) %>% - mutate(across(matches("\\.new$"), - ~ coalesce(., get(sub("\\.new$", "", cur_column()))), - .names = "{.col}" - )) %>% - select(-ends_with(".new")) - } else { - # Create a new regional_summary from the event_adjusted dataframe - result$regional_data$regional_summary <- event_adjusted - } - - result$global_adjustment_info <- list( - local_method = result$local_adjustment_info$method, - p_value_columns = p_columns, - fdr_columns = fdr_columns, - q_columns = q_columns, - statistics = statistics - ) - - return(result) -} - -############################################ -# SNP Identification (Step 3) -############################################ - -identify_permutation_snps <- function(data, params) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - message("Identifying significant SNPs using permutation thresholds...") - - # Check if permutation data (with beta parameters) is available - if (is.null(data$regional_data) || is.null(data$regional_data$regional_summary) || - !all(c("p_beta", "q_beta", "beta_shape1", "beta_shape2") %in% colnames(data$regional_data$regional_summary))) { - warning("Permutation data (p_beta, q_beta, beta shape parameters) not available") - # Return data with empty significant QTLs - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[["permutation_significant"]] <- data.frame() - return(data) - } - - # Calculate threshold using p_beta and q_beta specifically - regional_data <- data$regional_data$regional_summary - - # Find significant and non-significant p_beta values - lb <- regional_data %>% - filter(q_beta <= params$fdr_threshold) %>% - pull(p_beta) %>% - sort() - - ub <- regional_data %>% - filter(q_beta > params$fdr_threshold) %>% - pull(p_beta) %>% - sort() - - if (length(lb) > 0) { - lb_val <- tail(lb, 1) # Max p_beta that passes threshold - threshold <- if (length(ub) > 0) { - (lb_val + head(ub, 1)) / 2 # Average with min p_beta that fails - } else { - lb_val # Just use max passing if no failures - } - - message(sprintf( - "Min p-value threshold @ q_beta %.2f: %g", - params$fdr_threshold, threshold - )) - - # Update regional summary with permutation threshold - updated_regional_data <- regional_data %>% - mutate(p_nominal_threshold = qbeta(threshold, beta_shape1, beta_shape2)) - - data$regional_data$regional_summary <- updated_regional_data - - # Identify significant SNPs using permutation threshold - significant_pairs <- data$qtl_data$data %>% - left_join( - updated_regional_data %>% select(!!sym(molecular_id_col), p_nominal_threshold), - by = molecular_id_col - ) %>% - filter(!!sym(data$qtl_data$column_info$p_col) < p_nominal_threshold) - - # Store significant SNPs - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[["permutation_significant"]] <- significant_pairs - significant_events <- data$regional_data$regional_summary %>% - filter(q_beta < params$fdr_threshold) - message(sprintf( - "Identified %d significant SNPs from %d events using permutation thresholds", - nrow(significant_pairs), nrow(significant_events) - )) - } else { - message("No significant events found using q_beta threshold") - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[["permutation_significant"]] <- data.frame() - } - - return(data) -} - -identify_bonferroni_fdr_snps <- function(data, params) { - message("Identifying significant SNPs using Bonferroni adjusted p-value thresholds...") - - # Get FDR column for Bonferroni - fdr_bonferroni_col <- "fdr_bonferroni_min" - p_bonferroni_col <- "p_bonferroni_min" - - # Check if columns exist in regional_summary - if (!all(c(fdr_bonferroni_col, p_bonferroni_col) %in% - names(data$regional_data$regional_summary))) { - warning("Required p-value and FDR columns not found in regional summary") - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[["bonferroni_fdr_original"]] <- data.frame() - return(data) - } - - # Identify significant events using FDR threshold - significant_events <- data$regional_data$regional_summary %>% - filter(!!sym(fdr_bonferroni_col) < params$fdr_threshold) - - if (nrow(significant_events) == 0) { - message(sprintf( - "No significant events identified at %s threshold %g", - fdr_bonferroni_col, params$fdr_threshold - )) - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[["bonferroni_fdr_original"]] <- data.frame() - return(data) - } - - # Calculate threshold as maximum p-value among significant events - threshold <- max(significant_events[[p_bonferroni_col]], na.rm = TRUE) - - # Identify significant SNPs - significant_pairs <- data$qtl_data$data %>% - filter(p_bonferroni_adj <= threshold) - - # Create result name - result_name <- sprintf( - "bonferroni_fdr_%s", - if (data$local_adjustment_info$is_filtered) "filtered" else "original" - ) - - # Store significant SNPs - if (is.null(data$significant_qtls)) data$significant_qtls <- list() - data$significant_qtls[[result_name]] <- significant_pairs - - message(sprintf( - "Identified %d significant SNPs from %d events using Bonferroni adjusted p-value threshold %g", - nrow(significant_pairs), nrow(significant_events), threshold - )) - return(data) -} - -identify_qvalue_snps <- function(data, params, base_data = NULL) { - molecular_id_col <- params$molecular_id_col %||% "molecular_trait_object_id" - message("Identifying significant SNPs using q-value per event method...") - if (is.null(base_data)) base_data <- data - base_data$significant_qtls <- list() - - regional_data <- base_data$regional_data$regional_summary - # First try to find q_beta (permutation-based) - q_col <- if ("q_beta" %in% names(regional_data)) { - message("Using permutation-based q_beta for significant events in qvalue-based QTL identification") - "q_beta" - } else if ("q_bonferroni_min" %in% names(regional_data)) { - message("Using Bonferroni-based q_bonferroni_min for significant events in qvalue-based QTL identification") - "q_bonferroni_min" - } else { - stop("Neither q_beta nor q_bonferroni_min found in regional data") - } - - result_name <- sprintf("%s_adjusted_events_qvalue", q_col) - - # Identify significant events - significant_events <- regional_data %>% - filter(!!sym(q_col) < params$fdr_threshold) %>% - pull(!!sym(molecular_id_col)) - if (length(significant_events) == 0) { - message(sprintf("No significant events found using %s threshold %g", q_col, params$fdr_threshold)) - base_data$significant_qtls[[result_name]] <- data.frame() - return(base_data) - } - snp_data <- data$qtl_data$data %>% - filter(!!sym(molecular_id_col) %in% significant_events) - - # Handle empty snp_data - if (nrow(snp_data) == 0) { - message("No SNP data for significant events") - base_data$significant_qtls[[result_name]] <- data.frame() - return(base_data) - } - - # Use existing q-value column - q_value_col <- data$qtl_data$column_info$q_col - if (!q_value_col %in% names(snp_data)) { - stop(sprintf("Q-value column '%s' not found. Please ensure q-values are computed before analysis.", q_value_col)) - } - - message(sprintf("Using existing q-value column '%s' for qvalue-based QTL identification", q_value_col)) - significant_snps <- snp_data %>% - filter(!!sym(q_value_col) < params$fdr_threshold) - - # Create result name based on method used - base_data$method_name <- q_col - - # Store significant SNPs - base_data$significant_qtls[[result_name]] <- significant_snps - message(sprintf( - "Identified %d significant SNPs from %d events using q-value method with %s as event level significance test", - nrow(significant_snps), length(significant_events), q_col - )) - return(base_data) -} - -############################################ -# Main Application Controller -############################################ -hierarchical_multiple_testing_correction <- function(params) { - # Set default molecular_id_col if not provided - if (is.null(params$molecular_id_col)) { - params$molecular_id_col <- "molecular_trait_object_id" - } - - # Step 0: Load all data upfront - data <- list() - data$regional_data <- load_regional_data(params) - recount_n_variants <- FALSE - if ((params$maf_cutoff > 0 || params$cis_window > 0) || is.null(params$regional_pattern)) { - recount_n_variants <- TRUE - } - - data$qtl_data <- load_qtl_data(params, load_n_variants = recount_n_variants) - regional_base <- paste0(data$qtl_data$file_prefix, ".cis_regional") - qtl_base <- paste0(data$qtl_data$file_prefix, ".cis_pairs") - results <- list() - - # Step 1A: Permutation-based local adjustment - if (data$regional_data$has_permutation) { - perm_results <- permutation_local_adjustment(data, params) - perm_results <- perform_global_adjustment(perm_results, params) - perm_results <- identify_permutation_snps(perm_results, params) - results$permutation <- list( - regional_data = list( - regional_summary = perm_results$regional_data$regional_summary - ), - significant_qtls = perm_results$significant_qtls[[1]], - output_metadata = list( - regional = paste0(regional_base, ".permutation_adjusted.fdr.gz"), - events = list( - path = paste0(regional_base, ".significant_events.permutation_adjusted.tsv.gz"), - filter_column = "q_beta", - filter_threshold = params$fdr_threshold - ), - qtls = paste0(qtl_base, ".significant_qtl.permutation_adjusted.tsv.gz") - ), - global_adjustment_info = list( - statistics = perm_results$global_adjustment_info$statistics - ) - ) - } - - # Step 1B: Bonferroni local adjustment (original) - bonf_orig_results <- bonferroni_local_adjustment(data, params, should_filter = FALSE) - bonf_orig_results <- perform_global_adjustment(bonf_orig_results, params) - bonf_orig_results <- identify_bonferroni_fdr_snps(bonf_orig_results, params) - results$bonferroni_original <- list( - regional_data = list( - regional_summary = bonf_orig_results$regional_data$regional_summary - ), - significant_qtls = bonf_orig_results$significant_qtls[[1]], - output_metadata = list( - regional = paste0(regional_base, ".original_bonferroni_BH_adjusted.fdr.gz"), - events = list( - path = paste0(regional_base, ".significant_events.original_bonferroni_BH_adjusted.tsv.gz"), - filter_column = "fdr_bonferroni_min", - filter_threshold = params$fdr_threshold - ), - qtls = paste0(qtl_base, ".significant_qtl.original_bonferroni_BH_adjusted.tsv.gz") - ), - global_adjustment_info = list( - statistics = bonf_orig_results$global_adjustment_info$statistics %||% list() - ) - ) - - # Step 1C: Bonferroni local adjustment (filtered) - if (params$maf_cutoff > 0 || params$cis_window > 0) { - bonf_filt_results <- bonferroni_local_adjustment(data, params, should_filter = TRUE) - bonf_filt_results <- perform_global_adjustment(bonf_filt_results, params) - bonf_filt_results <- identify_bonferroni_fdr_snps(bonf_filt_results, params) - results$bonferroni_filtered <- list( - regional_data = list( - regional_summary = bonf_filt_results$regional_data$regional_summary - ), - significant_qtls = bonf_filt_results$significant_qtls[[1]], - output_metadata = list( - regional = paste0(regional_base, ".filtered_bonferroni_BH_adjusted.fdr.gz"), - events = list( - path = paste0(regional_base, ".significant_events.filtered_bonferroni_BH_adjusted.tsv.gz"), - filter_column = "fdr_bonferroni_min", - filter_threshold = params$fdr_threshold - ), - qtls = paste0(qtl_base, ".significant_qtl.filtered_bonferroni_BH_adjusted.tsv.gz") - ), - global_adjustment_info = list( - statistics = bonf_filt_results$global_adjustment_info$statistics %||% list() - ) - ) - } - - # Step 1D: Apply q-value per SNP methodology - qvalue_base <- results$permutation %||% results$bonferroni_filtered %||% results$bonferroni_original - qvalue_results <- identify_qvalue_snps(data, params, qvalue_base) - results$qvalue <- list( - regional_data = list( - regional_summary = qvalue_results$regional_data$regional_summary - ), - significant_qtls = qvalue_results$significant_qtls[[1]], - output_metadata = list( - events = NULL, # q-value based methods copies some previous event result so it does not help to output it additionally - qtls = paste0(qtl_base, ".significant_qtl.", names(qvalue_results$significant_qtls), ".tsv.gz") - ), - global_adjustment_info = list( - statistics = qvalue_results$global_adjustment_info$statistics %||% list() - ) - ) - - # Add summary metadata - results$summary_metadata <- paste0(regional_base, ".summary.txt") - return(results) -} -############################################ -# Output Management -############################################ - -write_results <- function(results, out_dir, work_dir, to_cwd = c("regional")) { - setwd(work_dir) - summary_stats <- list() - if (!dir.exists(out_dir)) { - dir.create(out_dir, recursive = TRUE) - message(sprintf("Created directory: %s", out_dir)) - } - - # Process each analysis result - for (result_name in names(results)) { - if (result_name == "summary_metadata") next - - result <- results[[result_name]] - - # Extract statistics for summary - if (!is.null(result$global_adjustment_info$statistics)) { - for (stat_name in names(result$global_adjustment_info$statistics)) { - full_name <- paste0(result_name, "_", stat_name) - summary_stats[[full_name]] <- result$global_adjustment_info$statistics[[stat_name]] - } - } - - # Write output files based on metadata - meta <- result$output_metadata - - # Write regional data - if (!is.null(meta$regional)) { - # Choose directory based on to_cwd parameter - dir_path <- if ("regional" %in% to_cwd) "." else out_dir - full_path <- file.path(dir_path, meta$regional) - write_delim(result$regional_data$regional_summary, gzfile(full_path), delim = "\t") - } - - # Write events data - if (!is.null(meta$events)) { - dir_path <- if ("events" %in% to_cwd) "." else out_dir - events_data <- result$regional_data$regional_summary %>% - filter(!!sym(meta$events$filter_column) < meta$events$filter_threshold) - if (nrow(events_data) > 0) { - full_path <- file.path(dir_path, meta$events$path) - write_delim(events_data, gzfile(full_path), delim = "\t") - } - } - - # Write QTLs data - if (!is.null(meta$qtls)) { - dir_path <- if ("qtls" %in% to_cwd) "." else out_dir - full_path <- file.path(dir_path, meta$qtls) - write_delim(result$significant_qtls, gzfile(full_path), delim = "\t") - } - } - - # Write summary table - if (length(summary_stats) == 0) { - summary_tbl <- data.frame(note = "No statistics calculated with available data") - } else { - summary_tbl <- data.frame( - statistic = names(summary_stats), - value = unlist(summary_stats) - ) - } - - # Determine if summary should go to CWD - dir_path <- if ("summary" %in% to_cwd) "." else out_dir - write.table(summary_tbl, file.path(dir_path, results$summary_metadata), - sep = "\t", row.names = FALSE, quote = FALSE - ) -} - -archive_files <- function(params) { - archive_dir <- params$archive_dir - workdir <- params$workdir - - original_wd <- getwd() - setwd(workdir) - - warn_log <- c() - withCallingHandlers( - { - files_to_archive <- c( - list.files(pattern = "parquet$", full.names = TRUE), - list.files(pattern = "regional\\.(fdr\\.gz|summary\\.txt)$", full.names = TRUE) - ) - - existing_files <- files_to_archive[file.exists(files_to_archive)] - existing_files <- unique(existing_files) - - message(sprintf("Found %d files to archive", length(existing_files))) - message(sprintf("Archive directory is: %s", archive_dir)) - - if (length(existing_files) > 0) { - # Create archive directory - if (!dir.exists(archive_dir)) { - dir.create(archive_dir, recursive = TRUE) - message(sprintf("Created archive directory: %s", archive_dir)) - } - - # Move files to archive - moved_count <- 0 - for (file_path in existing_files) { - target_path <- file.path(archive_dir, basename(file_path)) - if (file.exists(target_path)) { - message(sprintf("Skipping already archived file: %s", basename(file_path))) - } else { - - success <- file.rename(file_path, target_path) - if (success) { - moved_count <- moved_count + 1 - } else { - message(sprintf("WARNING: Failed to move file: %s to %s", file_path, target_path)) - - copy_success <- file.copy(file_path, target_path) - if (copy_success) { - remove_success <- file.remove(file_path) - if (remove_success) { - moved_count <- moved_count + 1 - message(sprintf("Successfully archived using copy+remove: %s", basename(file_path))) - } else { - message(sprintf("WARNING: Copied but failed to remove original: %s", file_path)) - } - } else { - message(sprintf("ERROR: Failed to copy: %s to %s", file_path, target_path)) - } - } - } - } - - message(sprintf("Archived %d/%d files", moved_count, length(existing_files))) - } else { - message("No files found to archive") - } - }, - warning = function(w) { - warn_log <<- c(warn_log, conditionMessage(w)) - invokeRestart("muffleWarning") - } - ) - - if (length(warn_log) > 0) { - message("Captured warnings:") - for (i in seq_along(warn_log)) { - message(sprintf("%d: %s", i, warn_log[i])) - } - } - - # Restore original working directory - setwd(original_wd) - - return(invisible(warn_log)) -} - -# source("~/GIT/pecotmr/code/tensorqtl_postprocessor.R") -# results <- hierarchical_multiple_testing_correction(params) -# write_results(results, params$output_dir, params$workdir, to_cwd = "regional") -# archive_files(params) -# saveRDS(results, "test.rds") diff --git a/inst/misc/post-commit.sh b/inst/misc/post-commit.sh deleted file mode 100755 index 2471d17a..00000000 --- a/inst/misc/post-commit.sh +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/bash -# -# This script will be executed every time you run "git commit". It -# will commit changes made to package DESCRIPTION by the pre-commit hook -# -# To use this script, copy it to the .git/hooks directory of your -# local repository to filename `post-commit`, and make it executable. -# -ROOT_DIR=`git rev-parse --show-toplevel` -# Only commit DESCRIPTION file when it is not staged (due to changes by pre-commit hook) -if [[ -z `git diff HEAD` ]] || [[ ! -f $ROOT_DIR/DESCRIPTION ]] || [[ -z `git diff $ROOT_DIR/DESCRIPTION` ]]; then - exit 0 -else - git add $ROOT_DIR/DESCRIPTION - git commit --amend -C HEAD --no-verify - echo "Amend current commit to incorporate version bump" - exit 0 -fi diff --git a/inst/misc/pre-commit.sh b/inst/misc/pre-commit.sh deleted file mode 100755 index a1aac9c5..00000000 --- a/inst/misc/pre-commit.sh +++ /dev/null @@ -1,36 +0,0 @@ -#!/bin/bash -# -# This script will be executed every time you run "git commit". It -# will update the 4th digit of package version by revision number. -# -# To use this script, copy it to the .git/hooks directory of your -# local repository to filename `pre-commit`, and make it executable. -# -ROOT_DIR=`git rev-parse --show-toplevel` -MSG="[WARNING] Auto-versioning disabled because string 'Version: x.y.z.r' cannot be found in DESCRIPTION file." -GREP_REGEX='^Version: [0-9]*\.[0-9]*\.[0-9]*\.[0-9]*' -SED_REGEX='^Version: \([0-9]*\.[0-9]*\.[0-9]*\)\.[0-9]*' -# `git diff HEAD` shows both staged and unstaged changes -if [[ -z `git diff HEAD` ]] || [[ ! -f $ROOT_DIR/DESCRIPTION ]]; then - exit 0 -elif [[ -z `grep "$GREP_REGEX" $ROOT_DIR/DESCRIPTION` ]]; then - echo -e "\e[1;31m$MSG\e[0m" - exit 0 -else - REV_ID=`git log --oneline | wc -l` - REV_ID=`printf "%04d\n" $((REV_ID+1))` - DATE=`date +%Y-%m-%d` - echo "Version string bumped to revision $REV_ID on $DATE" - sed -i "s/$SED_REGEX/Version: \1.$REV_ID/" $ROOT_DIR/DESCRIPTION - sed -i "s/^Date: .*/Date: $DATE/" $ROOT_DIR/DESCRIPTION - if [[ `git rev-parse --abbrev-ref HEAD` -eq "master" ]]; then - cd $ROOT_DIR - echo "Updating documentation ..." - R --slave -e 'devtools::document()' &> /dev/null && git add man/*.Rd - echo "Documentation updated!" - echo "Running unit tests ..." - R --slave -e 'devtools::test()' - echo "Unit test completed!" - fi - exit 0 -fi diff --git a/inst/notes/otters_lassosum_selector_fix_pr.md b/inst/notes/otters_lassosum_selector_fix_pr.md deleted file mode 100644 index 5b6bb209..00000000 --- a/inst/notes/otters_lassosum_selector_fix_pr.md +++ /dev/null @@ -1,145 +0,0 @@ -# OTTERS Lassosum LD-Quadratic Selector Fix - -## Summary - -This PR fixes the OTTERS lassosum regression by removing the old `min(fbeta)` -selector from the default OTTERS path and replacing it with the LD-quadratic -selector - -```text -score(beta) = (c^T beta) / sqrt(beta^T R beta) -``` - -where: - -- `c` is the aligned summary-statistics correlation vector -- `R` is the supplied LD correlation matrix -- `beta` is one candidate on the lassosum `(s, lambda)` path - -The important conclusion from the follow-up diagnostics is that genotype is not -fundamentally required for lassosum selection once the selector is written in -this LD form. The remaining sketch issue is about how `R` is constructed or -standardized, not about the selector formula itself. - -## What Failed - -Old OTTERS did not select lassosum models by `min(fbeta)`. It fit the beta path -and then used lassosum pseudovalidation to choose the final `(s, lambda)`. - -The refactor changed that selector to `min(fbeta)`, and the OTTERS wrapper also -double-scaled the lassosum input before it reached the low-level solver. - -Those two changes were enough to move the selected model to a very different -part of the same grid. - -## Example 206 - -Fixture `chr1_206088859_208088859__ENSG00000123843` isolates the selector bug. - -- old saved vs old direct published `lassosum`: Pearson `1.0`, `0` opposite-sign variants -- corrected-scaling + `min(fbeta)`: Pearson about `0.360`, `1309` opposite-sign variants - -On this fixture: - -- published lassosum selected `s = 0.2`, `lambda = 1e-4` -- `min(fbeta)` selected `s = 1`, `lambda = 1e-4` - -This is not a grid-definition problem. Both candidates are already on the old -grid. The regression comes from changing the selection rule over the same -candidate path. - -## Mathematical Rationale - -Old pseudovalidation can be written as: - -```text -scaled_beta = beta / sd -pred = X * scaled_beta -score = (c^T beta) / sqrt(Var(pred)) -``` - -After centering and standardizing the columns of `X` by the same per-variant -scale, this becomes: - -```text -score(beta) = (c^T beta) / sqrt(beta^T R beta) -``` - -So the selector can be evaluated directly from summary-statistics correlation -and LD, without using genotype explicitly. That is the selector implemented in -this PR. - -## Validation - -We validated the LD-quadratic score against the corresponding source-matched -sample-matrix pseudovalidation on the same candidate matrix. - -### PLINK1 source: genotype matrix vs LD-quadratic - -The LD-quadratic score from PLINK1-derived LD matches PLINK1 genotype -pseudovalidation essentially exactly. - -- Fixture `161`: - - PLINK1 genotype best: `soft_lambda=0.041050213` - - PLINK1 LD-quadratic best: `soft_lambda=0.041050213` - - Pearson `0.9999999` - - same best candidate `TRUE` -- Fixture `206`: - - PLINK1 genotype best: `soft_lambda=0.029906976` - - PLINK1 LD-quadratic best: `soft_lambda=0.029906976` - - Pearson `1.0000000` - - same best candidate `TRUE` - -This validates the selector formula itself. - -### Sketch source: sample matrix vs LD-quadratic - -For the sketch source, the sample-matrix pseudovalidation and the LD-quadratic -score are the same numeric object once both are built from the same restored -sketch matrix and the same column standardization. - -- Fixture `161`: - - sketch sample-matrix best: `soft_lambda=0.021788613` - - sketch LD-quadratic best: `soft_lambda=0.021788613` - - Pearson `1.0` - - max absolute difference `< 1e-15` - - same best candidate `TRUE` - -So the remaining mismatch is not between "sample-matrix pseudovalidation" and -"quadratic LD scoring". It is between the current sketch representation and the -PLINK1/genotype-backed standardized LD path. - -## What This PR Changes - -## `R/regularized_regression.R` - -- fixes the OTTERS lassosum scaling contract so correlation input is only - converted once before the low-level solver -- removes genotype-format-specific selector dispatch from - `lassosum_rss_weights()` -- makes the default selector `ld_quadratic` -- keeps `min(fbeta)` only as an explicit debug option -- preserves first-max tie behavior for equal selector scores - -## `R/otters.R` - -- passes correlation-scale statistics into lassosum explicitly via - `stat$cor` / `stat$z` -- removes the temporary genotype-source / variant-metadata plumbing that was - only needed for the earlier compatibility patch - -## Scope - -This PR only changes the OTTERS lassosum selection path. - -- It does not change PRS-CS or SDPR behavior. -- It does not claim the current sketch-derived LD is already identical to the - PLINK1/genotype-backed path. -- It does claim that the selector should be implemented in LD form, and that - `min(fbeta)` was the wrong default for OTTERS parity. - -## Evidence Paths - -- `temp_reference/otters_regression/lassosum_oldR_direct_206/` -- `temp_reference/otters_regression/lassosum_forensics_206/` -- `temp_reference/otters_regression/pseudovalidation_sketch_vs_bfile/` diff --git a/data-raw/build_examples.R b/inst/scripts/build_examples.R similarity index 100% rename from data-raw/build_examples.R rename to inst/scripts/build_examples.R diff --git a/inst/misc/format_r_code.sh b/inst/scripts/format_r_code.sh similarity index 100% rename from inst/misc/format_r_code.sh rename to inst/scripts/format_r_code.sh diff --git a/man/AnnotationMatrix.Rd b/man/AnnotationMatrix.Rd index 69085037..daeae3c4 100644 --- a/man/AnnotationMatrix.Rd +++ b/man/AnnotationMatrix.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2Annotations.R +% Please edit documentation in R/AnnotationMatrix.R \name{AnnotationMatrix} \alias{AnnotationMatrix} \title{Create an AnnotationMatrix Object} diff --git a/man/GwasFineMappingResult.Rd b/man/GwasFineMappingResult.Rd index f5c7c0b3..92bce492 100644 --- a/man/GwasFineMappingResult.Rd +++ b/man/GwasFineMappingResult.Rd @@ -10,6 +10,7 @@ GwasFineMappingResult( entry, region_id = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL ) } diff --git a/man/GwasSumStats.Rd b/man/GwasSumStats.Rd index 672dad03..f2448020 100644 --- a/man/GwasSumStats.Rd +++ b/man/GwasSumStats.Rd @@ -8,7 +8,7 @@ GwasSumStats( study, entry, genome, - ldSketch, + ldSketch = NULL, varY = NA_real_, nCase = NULL, nControl = NULL, diff --git a/man/QtlFineMappingResult.Rd b/man/QtlFineMappingResult.Rd index 76e19286..e73dab36 100644 --- a/man/QtlFineMappingResult.Rd +++ b/man/QtlFineMappingResult.Rd @@ -14,6 +14,7 @@ QtlFineMappingResult( jointContexts = NULL, jointTraits = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL ) } diff --git a/man/QtlSumStats.Rd b/man/QtlSumStats.Rd index 40b30f38..898ab7eb 100644 --- a/man/QtlSumStats.Rd +++ b/man/QtlSumStats.Rd @@ -10,9 +10,10 @@ QtlSumStats( trait, entry, genome, - ldSketch, + ldSketch = NULL, varY = NA_real_, qcInfo = list(), + traitPos = NULL, ... ) } diff --git a/man/SumStatsBase-class.Rd b/man/SumStatsBase-class.Rd index 5c332e83..3c39e471 100644 --- a/man/SumStatsBase-class.Rd +++ b/man/SumStatsBase-class.Rd @@ -14,7 +14,9 @@ Virtual base class for QTL and GWAS summary statistics \describe{ \item{\code{ldSketch}}{The \code{GenotypeHandle} the QC pipeline harmonized -against. Required: \code{summaryStatsQc()} sets it.} +against, or \code{NULL}. Optional: LD-free workflows (e.g. mash, which +operates across conditions per variant) carry \code{NULL}; pipelines that +need LD validate its presence when they consume the collection.} \item{\code{genome}}{Character, genome build label.} diff --git a/man/TwasWeights.Rd b/man/TwasWeights.Rd index a699d2ad..fb8a1b87 100644 --- a/man/TwasWeights.Rd +++ b/man/TwasWeights.Rd @@ -14,6 +14,7 @@ TwasWeights( jointContexts = NULL, jointTraits = NULL, region = NULL, + traitPos = NULL, ldSketch = NULL ) } diff --git a/man/calculateFeatureScores.Rd b/man/calculateFeatureScores.Rd new file mode 100644 index 00000000..db99577a --- /dev/null +++ b/man/calculateFeatureScores.Rd @@ -0,0 +1,28 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{calculateFeatureScores} +\alias{calculateFeatureScores} +\title{Feature score from deviation contrasts (random-effects meta per condition)} +\usage{ +calculateFeatureScores(contrastResult, metaMethod = "REML") +} +\arguments{ +\item{contrastResult}{A contrast table from \code{\link{mashPosteriorContrast}} +(variants x contrasts) carrying \code{mean_contrast_*_deviation} and +\code{se_contrast_*_deviation} columns.} + +\item{metaMethod}{Between-study variance estimator forwarded to +\code{metafor::rma} (default \code{"REML"}).} +} +\value{ +A \code{data.frame} with \code{condition} and \code{zScore}. +} +\description{ +For each condition's deviation contrast, meta-analyzes the per-variant +absolute effect sizes (random-effects, via \code{metafor::rma}) and returns +the pooled Z-score (\eqn{\hat\mu / \mathrm{se}}). One score per condition -- +the "meta" feature score of \code{mash_posterior.ipynb}. +} +\seealso{ +\code{\link{nSignificantScore}}, \code{\link{scoreFromCs}} +} diff --git a/man/buildTopLoci.Rd b/man/dot-fullFitColumns.Rd similarity index 91% rename from man/buildTopLoci.Rd rename to man/dot-fullFitColumns.Rd index a04e3f8d..f9e51111 100644 --- a/man/buildTopLoci.Rd +++ b/man/dot-fullFitColumns.Rd @@ -1,22 +1,20 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/fineMappingWrappers.R -\name{buildTopLoci} -\alias{buildTopLoci} +\name{.fullFitColumns} +\alias{.fullFitColumns} \title{Build the unified top-loci table for one fit and one method.} \usage{ -buildTopLoci( - fit, - csTables, - variantNames, - sumstats = NULL, - af = NULL, - method, - signalCutoff = 0, - dataX = NULL, - dataY = NULL, - otherQuantities = NULL, - region = NULL, - conditionIdx = NULL +.fullFitColumns( + alpha, + mu, + mu2, + lbfMat, + scale, + primaryCsPos, + effectOf, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE ) } \arguments{ diff --git a/man/dprWeights.Rd b/man/dprWeights.Rd index db4a6b06..75dec0d0 100644 --- a/man/dprWeights.Rd +++ b/man/dprWeights.Rd @@ -30,7 +30,7 @@ A numeric vector of length `ncol(X)` of variant weights. \description{ Fits a Dirichlet Process Regression model via `RcppDPR::fit_model` and returns the per-variant weights, computed as `beta + alpha` (matching -`RcppDPR:::predict.DPR_Model`, which uses `(beta + alpha) %*% x_new + pheno_mean`). +RcppDPR's internal `predict.DPR_Model`, which uses `(beta + alpha) %*% x_new + pheno_mean`). } \details{ By default the variational Bayes (`VB`) fitting method is used, which is diff --git a/man/estCtwasParam.Rd b/man/estCtwasParam.Rd index c0c1f284..93159055 100644 --- a/man/estCtwasParam.Rd +++ b/man/estCtwasParam.Rd @@ -29,7 +29,7 @@ estCtwasParam( \item{fallbackToPrefit}{Logical (length 1). When \code{TRUE} (default \code{FALSE}), if \code{ctwas::est_param}'s accurate EM fails for ANY reason on a degenerate input, re-run only the prefit step via -\code{ctwas:::fit_EM} and return those (typically finite) priors as the +ctwas's internal \code{fit_EM} and return those (typically finite) priors as the param. The accurate-EM failure mode is version-dependent (ctwas <= 0.4.x: \code{"contains NAs"}; ctwas >= 0.6.0: \code{"No regions selected!"} or a NaN-loglik \code{"missing value where TRUE/FALSE needed"}), so the catch is diff --git a/man/fineMappingPipeline.Rd b/man/fineMappingPipeline.Rd index 771e95ba..fe645639 100644 --- a/man/fineMappingPipeline.Rd +++ b/man/fineMappingPipeline.Rd @@ -48,6 +48,9 @@ fineMappingPipeline(data, ...) naAction = c("drop", "impute"), verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, phenotypeCovariatesToResidualize = NULL, genotypeCovariatesToResidualize = NULL, residualizePhenotypeCovariates = TRUE, @@ -81,6 +84,9 @@ fineMappingPipeline(data, ...) naAction = c("drop", "impute"), verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, phenotypeCovariatesToResidualize = NULL, genotypeCovariatesToResidualize = NULL, residualizePhenotypeCovariates = TRUE, @@ -105,6 +111,9 @@ fineMappingPipeline(data, ...) dataDrivenPriorWeightsCutoff = 1e-10, verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, ... ) @@ -122,6 +131,9 @@ fineMappingPipeline(data, ...) fineMappingResult = NULL, verbose = 1, trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE, ... ) @@ -269,6 +281,26 @@ downstream pipelines). When \code{FALSE} the full untrimmed per-variant \code{topLoci} table is always fully populated regardless of \code{trim}.} +\item{fullFit}{Logical (length 1, default \code{FALSE}). Master switch for +per-credible-set variant-level export in \code{topLoci}. When \code{FALSE}, +only the always-on \code{within_cs_pip} scalar column is added (each +variant's \code{alpha} in its assigned primary-coverage credible set; NA +when not in a set). When \code{TRUE}, wide per-CS columns are added, one +set of columns per credible set (labelled \code{cs}).} + +\item{fullFitAlphaOnly}{Logical (length 1, default \code{TRUE}). No-op when +\code{fullFit=FALSE}. When \code{TRUE}, only \code{alpha} is widened +(\code{within_cs_pip_cs}). When \code{FALSE}, all four per-effect +matrices are widened: \code{within_cs_pip_cs} (alpha), +\code{cs_logbf_cs} (lbf_variable), \code{cs_effect_cs} (mu, unscaled) +and \code{cs_effect_var_cs} (posterior variance, unscaled).} + +\item{includeAllCs}{Logical (length 1, default \code{FALSE}). No-op when +\code{fullFit=FALSE}. When \code{FALSE}, only effects that produced a +passing (purity/coverage-filtered) credible set are widened. When +\code{TRUE}, every effect \code{L} is widened (including filtered-out ones, +labelled \code{L} instead of \code{cs}).} + \item{phenotypeCovariatesToResidualize}{Character vector (or \code{NULL}) of phenotype-covariate names to residualize against. \code{NULL} (default) uses every available phenotype covariate. diff --git a/man/fsusieAffectedRegions.Rd b/man/fsusieAffectedRegions.Rd new file mode 100644 index 00000000..6142c06d --- /dev/null +++ b/man/fsusieAffectedRegions.Rd @@ -0,0 +1,33 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fsusieAccessors.R +\name{fsusieAffectedRegions} +\alias{fsusieAffectedRegions} +\alias{fsusieAffectedRegions,FineMappingEntry-method} +\alias{fsusieAffectedRegions,FineMappingResultBase-method} +\title{fSuSiE affected genomic regions} +\usage{ +fsusieAffectedRegions(x, ...) + +\S4method{fsusieAffectedRegions}{FineMappingEntry}(x, ...) + +\S4method{fsusieAffectedRegions}{FineMappingResultBase}(x, ...) +} +\arguments{ +\item{x}{A \code{FineMappingEntry} or \code{FineMappingResultBase}.} + +\item{...}{Ignored.} +} +\value{ +A \code{GRanges} of affected intervals with mcols \code{cs}, + \code{purity}, \code{direction} (plus entry identity for the collection). +} +\description{ +The sub-intervals of the functional grid where a credible set's band excludes +zero (the genomic footprint of each fSuSiE effect), from the upstream +\code{fsusieR::affected_reg}. Returns a \code{GRanges} with the credible-set +label, its purity, and the effect \code{direction} (\code{"pos"}/\code{"neg"}; +upstream discards it). Requires an UNtrimmed fit; empty otherwise. +} +\seealso{ +\code{\link{fsusieCredibleBand}} +} diff --git a/man/fsusieCredibleBand.Rd b/man/fsusieCredibleBand.Rd new file mode 100644 index 00000000..105bcb60 --- /dev/null +++ b/man/fsusieCredibleBand.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/fsusieAccessors.R +\name{fsusieCredibleBand} +\alias{fsusieCredibleBand} +\alias{fsusieCredibleBand,FineMappingEntry-method} +\alias{fsusieCredibleBand,FineMappingResultBase-method} +\title{fSuSiE credible band (fitted effect + uncertainty band)} +\usage{ +fsusieCredibleBand(x, ...) + +\S4method{fsusieCredibleBand}{FineMappingEntry}(x, ...) + +\S4method{fsusieCredibleBand}{FineMappingResultBase}(x, ...) +} +\arguments{ +\item{x}{A \code{FineMappingEntry} or \code{FineMappingResultBase}.} + +\item{...}{Ignored.} +} +\value{ +A long \code{data.frame}: \code{cs, chrom, pos, effect, lower, upper} + (the collection method additionally carries the entry identity columns). +} +\description{ +For a functional-SuSiE (\code{fsusieR::susiF}) fine-mapping entry, returns the +fitted effect curve and its credible band over the functional grid, one row +per (credible set, grid position). Wraps the upstream fSuSiE band computation +(fsusieR's internal \code{update_cal_credible_band.susiF} + \code{get_fitted_effect}). +Requires an UNtrimmed fit (the wavelet slots are dropped by trimming); +degrades to zero rows for non-fSuSiE or trimmed fits. +} +\seealso{ +\code{\link{fsusieAffectedRegions}} +} diff --git a/man/getBaseline.Rd b/man/getBaseline.Rd index f48519cb..4a679410 100644 --- a/man/getBaseline.Rd +++ b/man/getBaseline.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2Annotations.R +% Please edit documentation in R/AnnotationMatrix.R \name{getBaseline} \alias{getBaseline} \title{Get Baseline Annotations} diff --git a/man/getBeta.Rd b/man/getBeta.Rd new file mode 100644 index 00000000..9096b034 --- /dev/null +++ b/man/getBeta.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{getBeta} +\alias{getBeta} +\alias{getBeta,SumStatsBase-method} +\title{Get Marginal Effect Sizes} +\usage{ +getBeta(x, ...) + +\S4method{getBeta}{SumStatsBase}(x, ...) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Class-specific selection arguments.} +} +\value{ +Numeric vector of effect sizes, or \code{NULL} if not available. +} +\description{ +Extract the marginal effect-size (beta) vector from a + \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity + tuple. +} diff --git a/man/getCandidates.Rd b/man/getCandidates.Rd index d70d6a25..11906c3d 100644 --- a/man/getCandidates.Rd +++ b/man/getCandidates.Rd @@ -1,5 +1,5 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2Annotations.R +% Please edit documentation in R/AnnotationMatrix.R \name{getCandidates} \alias{getCandidates} \title{Get Candidate Annotations} diff --git a/man/getCredibleSetSummary.Rd b/man/getCredibleSetSummary.Rd new file mode 100644 index 00000000..45683a71 --- /dev/null +++ b/man/getCredibleSetSummary.Rd @@ -0,0 +1,37 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/credibleSetSummary.R +\name{getCredibleSetSummary} +\alias{getCredibleSetSummary} +\alias{getCredibleSetSummary,FineMappingEntry-method} +\alias{getCredibleSetSummary,FineMappingResultBase-method} +\title{Per-credible-set summary of a fine-mapping result} +\usage{ +getCredibleSetSummary(x, ...) + +\S4method{getCredibleSetSummary}{FineMappingEntry}(x, coverage = 0.95, ...) + +\S4method{getCredibleSetSummary}{FineMappingResultBase}(x, coverage = 0.95, ...) +} +\arguments{ +\item{x}{A \code{FineMappingEntry} or \code{FineMappingResultBase}.} + +\item{...}{Ignored.} + +\item{coverage}{Credible-set coverage to summarise. Default 0.95.} +} +\value{ +A \code{data.frame}: \code{cs, effect_id, coverage, n_variants, + purity_min, purity_mean, V, cs_log10bf} (strongest member logBF), + \code{cs_log_bf} (true per-effect single-effect log Bayes factor), + \code{cs_pip} (summed member PIP = inclusion mass captured), \code{cs_mean_effect} + (mean posterior conditional effect), \code{lead_variant, lead_pip} (the + collection method also carries the entry identity columns). +} +\description{ +One row per credible set (at a given coverage) with its size, purity, prior +variance, log Bayes factor, and lead variant — the per-CS complement to the +per-variant \code{\link{getCs}}. Replaces the legacy per-effect `effect.tsv`. +} +\seealso{ +\code{\link{getCs}}, \code{\link{getTopLoci}} +} diff --git a/man/getCs.Rd b/man/getCs.Rd index 37b4d2a7..5dbfed6f 100644 --- a/man/getCs.Rd +++ b/man/getCs.Rd @@ -17,10 +17,11 @@ getCs(x, ...) method = NULL, region = NULL, coverage = 0.95, + minPurity = NULL, ... ) -\S4method{getCs}{FineMappingEntry}(x, coverage = 0.95, ...) +\S4method{getCs}{FineMappingEntry}(x, coverage = 0.95, minPurity = NULL, ...) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getLbf.Rd b/man/getLbf.Rd new file mode 100644 index 00000000..2fcf159a --- /dev/null +++ b/man/getLbf.Rd @@ -0,0 +1,34 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/getLbf.R +\name{getLbf} +\alias{getLbf} +\alias{getLbf,FineMappingEntry-method} +\alias{getLbf,FineMappingResultBase-method} +\title{Per-variant per-effect log Bayes factors (wide)} +\usage{ +getLbf(x, ...) + +\S4method{getLbf}{FineMappingEntry}(x, ...) + +\S4method{getLbf}{FineMappingResultBase}(x, ...) +} +\arguments{ +\item{x}{A \code{FineMappingEntry} or \code{FineMappingResultBase}.} + +\item{...}{Ignored.} +} +\value{ +A \code{data.frame}: \code{variant_id} + \code{lbf_L1..lbf_LL} (the + collection method also carries the entry identity columns). +} +\description{ +The variant x effect matrix of single-effect log Bayes factors +(\code{lbf_variable}, or fSuSiE's \code{lBF}) from the stored fit: one row per +variant, one \code{lbf_L} column per effect. The per-variant scalar summary +(max across effects) is the \code{logBF} column of \code{\link{getTopLoci}}; +this accessor keeps the full per-effect breakdown. Across entries with +different effect counts the collection method NA-fills the ragged columns. +} +\seealso{ +\code{\link{getTopLoci}} (the scalar \code{logBF} column) +} diff --git a/man/getP.Rd b/man/getP.Rd new file mode 100644 index 00000000..c2b94cf5 --- /dev/null +++ b/man/getP.Rd @@ -0,0 +1,25 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{getP} +\alias{getP} +\alias{getP,SumStatsBase-method} +\title{Get Association P-values} +\usage{ +getP(x, ...) + +\S4method{getP}{SumStatsBase}(x, ...) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Class-specific selection arguments.} +} +\value{ +Numeric vector of p-values, or \code{NULL} if not available. +} +\description{ +Extract the association p-value vector from a + \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity + tuple. Part of the first-class summary-statistic column set alongside + \code{\link{getZ}} / \code{\link{getBeta}} / \code{\link{getSE}}. +} diff --git a/man/getSE.Rd b/man/getSE.Rd new file mode 100644 index 00000000..0b374581 --- /dev/null +++ b/man/getSE.Rd @@ -0,0 +1,24 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R +\name{getSE} +\alias{getSE} +\alias{getSE,SumStatsBase-method} +\title{Get Effect-Size Standard Errors} +\usage{ +getSE(x, ...) + +\S4method{getSE}{SumStatsBase}(x, ...) +} +\arguments{ +\item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} + +\item{...}{Class-specific selection arguments.} +} +\value{ +Numeric vector of standard errors, or \code{NULL} if not available. +} +\description{ +Extract the effect-size standard-error vector from a + \code{GwasSumStats} or \code{QtlSumStats} entry, selected by its identity + tuple. +} diff --git a/man/getSignificantQtls.Rd b/man/getSignificantQtls.Rd new file mode 100644 index 00000000..ac21cc02 --- /dev/null +++ b/man/getSignificantQtls.Rd @@ -0,0 +1,36 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/qtlAssociationPostprocess.R +\name{getSignificantQtls} +\alias{getSignificantQtls} +\alias{getSignificantQtls,QtlSumStats-method} +\title{Extract Significant cis-QTL Variants} +\usage{ +getSignificantQtls(x, ...) + +\S4method{getSignificantQtls}{QtlSumStats}( + x, + method = c("permutation", "bonferroni_original", "bonferroni_filtered", "qvalue"), + threshold = NULL +) +} +\arguments{ +\item{x}{A \code{QtlSumStats}.} + +\item{...}{Selection arguments (\code{method}, \code{threshold}).} + +\item{method}{Correction method whose significant variants to extract: +\code{"permutation"}, \code{"bonferroni_original"}, +\code{"bonferroni_filtered"}, or \code{"qvalue"}.} + +\item{threshold}{FDR threshold (defaults to the value stashed by +\code{qtlAssociationPostprocess}).} +} +\value{ +A \code{GRanges} (or list of GRanges) of the significant variants. +} +\description{ +Derive the significant variants under a given correction method + and FDR threshold from a \code{QtlSumStats} enriched by + \code{\link{qtlAssociationPostprocess}} (significance is computed on demand, + never stored). +} diff --git a/man/getSumStats.Rd b/man/getSumStats.Rd index 62d598fa..6fed8ed7 100644 --- a/man/getSumStats.Rd +++ b/man/getSumStats.Rd @@ -11,13 +11,29 @@ getSumStats(x, ...) \S4method{getSumStats}{MultiStudyQtlDataset}(x, ...) -\S4method{getSumStats}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL, ...) +\S4method{getSumStats}{QtlSumStats}( + x, + study = NULL, + context = NULL, + trait = NULL, + annotateSignificance = NULL, + ... +) } \arguments{ \item{x}{A \code{GwasSumStats}, \code{QtlSumStats}, or \code{MultiStudyQtlDataset} object.} \item{...}{Class-specific selection arguments (see above).} + +\item{annotateSignificance}{Optional correction-method name +(\code{"permutation"} / \code{"bonferroni_original"} / +\code{"bonferroni_filtered"} / \code{"qvalue"}). When set on a QtlSumStats +enriched by \code{\link{qtlAssociationPostprocess}}, a logical +\code{significant} mcol for that method is added to the returned entry (the +significance is derived on the fly, not stored). Flat export flattens this +full entry GRanges (all mcols) directly; note \code{\link{getSumstatDf}} is +a fixed GWAS-schema view and does not carry the association columns.} } \value{ A \code{GRanges}, a \code{QtlSumStats}, or \code{NULL}. diff --git a/man/getSumstatDf.Rd b/man/getSumstatDf.Rd index 7b3c55b3..c27bbf27 100644 --- a/man/getSumstatDf.Rd +++ b/man/getSumstatDf.Rd @@ -1,27 +1,27 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, +% R/gwasSumStats.R \name{getSumstatDf} \alias{getSumstatDf} -\alias{getSumstatDf,GwasSumStats-method} \alias{getSumstatDf,QtlSumStats-method} +\alias{getSumstatDf,GwasSumStats-method} \title{Get Standardized Sumstat Data Frame for One Tuple} \usage{ getSumstatDf(x, ...) -\S4method{getSumstatDf}{GwasSumStats}( +\S4method{getSumstatDf}{QtlSumStats}( x, study = NULL, + context = NULL, + trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE ) -\S4method{getSumstatDf}{QtlSumStats}( +\S4method{getSumstatDf}{GwasSumStats}( x, study = NULL, - context = NULL, - trait = NULL, require = character(0), derive = c("none", "zFromBetaSe"), keepChrPrefix = TRUE diff --git a/man/getTopLoci.Rd b/man/getTopLoci.Rd index e20ab28a..2f54e309 100644 --- a/man/getTopLoci.Rd +++ b/man/getTopLoci.Rd @@ -18,10 +18,17 @@ getTopLoci(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) trait = NULL, method = NULL, region = NULL, + minPurity = NULL, ... ) -\S4method{getTopLoci}{FineMappingEntry}(x, type = c("data.frame", "GRanges"), signalCutoff = 0.025, ...) +\S4method{getTopLoci}{FineMappingEntry}( + x, + type = c("data.frame", "GRanges"), + signalCutoff = 0.025, + minPurity = NULL, + ... +) } \arguments{ \item{x}{A \code{FineMappingEntry} or \code{FineMappingResult}.} diff --git a/man/getTraitPosition.Rd b/man/getTraitPosition.Rd new file mode 100644 index 00000000..3977d772 --- /dev/null +++ b/man/getTraitPosition.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/AllClasses.R, R/QtlDataset.R, +% R/qtlSumStats.R, R/twasWeights.R +\name{getTraitPosition} +\alias{getTraitPosition} +\alias{getTraitPosition,FineMappingResultBase-method} +\alias{getTraitPosition,QtlDataset-method} +\alias{getTraitPosition,QtlSumStats-method} +\alias{getTraitPosition,TwasWeights-method} +\title{Get Per-Row Trait Positions} +\usage{ +getTraitPosition(x, ...) + +\S4method{getTraitPosition}{FineMappingResultBase}(x, ...) + +\S4method{getTraitPosition}{QtlDataset}(x, traitId = NULL, ...) + +\S4method{getTraitPosition}{QtlSumStats}(x, traitId = NULL, ...) + +\S4method{getTraitPosition}{TwasWeights}(x, ...) +} +\arguments{ +\item{x}{The object.} + +\item{...}{Reserved for future use.} +} +\value{ +A \code{GRanges} with one range per row of \code{x}, or an empty + \code{GRanges} when the collection carries no trait-position provenance. +} +\description{ +Return the molecular feature's OWN genomic coordinates (the gene + / peak range; TSS = \code{start()}) for each row of a per-tuple collection, + as a \code{GRanges} with one range per row. Distinct from + \code{\link{getRegion}} (the fine-mapping window for a + \code{FineMappingResult}): the true trait position cannot be inferred from + summary statistics, so it is threaded from the QtlDataset \code{rowRanges} + or an explicit QtlSumStats trait-position and carried as provenance onto + \code{QtlFineMappingResult} and \code{TwasWeights}. +} diff --git a/man/getVarY.Rd b/man/getVarY.Rd index 374ddef9..08326dbf 100644 --- a/man/getVarY.Rd +++ b/man/getVarY.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, +% R/gwasSumStats.R \name{getVarY} \alias{getVarY} -\alias{getVarY,GwasSumStats-method} \alias{getVarY,QtlSumStats-method} +\alias{getVarY,GwasSumStats-method} \title{Get Phenotype Variance} \usage{ getVarY(x, ...) -\S4method{getVarY}{GwasSumStats}(x, study = NULL) - \S4method{getVarY}{QtlSumStats}(x, study = NULL, context = NULL, trait = NULL) + +\S4method{getVarY}{GwasSumStats}(x, study = NULL) } \arguments{ \item{x}{A \code{GwasSumStats} or \code{QtlSumStats} object.} diff --git a/man/mashCovarianceComponents.Rd b/man/mashCovarianceComponents.Rd new file mode 100644 index 00000000..9d534130 --- /dev/null +++ b/man/mashCovarianceComponents.Rd @@ -0,0 +1,49 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashCovarianceComponents} +\alias{mashCovarianceComponents} +\title{Build mash Data-Driven Covariance Components} +\usage{ +mashCovarianceComponents( + sumStatsList, + alpha, + vhat = NULL, + components = c("canonical", "pca", "flash", "flash_nonneg"), + nPcs = NULL, + inputScale = c("auto", "beta", "z"), + setSeed = 999 +) +} +\arguments{ +\item{sumStatsList}{Named list (or \code{S4Vectors::SimpleList}) with at least +\code{"strong"} (the discovery set the covariances are learned on).} + +\item{alpha}{mash \code{alpha}.} + +\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.} + +\item{nPcs}{PCs seeded into \code{cov_pca}. Default \code{ncol(Bhat) - 1}.} + +\item{inputScale}{SumStats -> matrix conversion scale.} + +\item{setSeed}{Integer seed (\code{cov_flash} is stochastic), or \code{NULL} +to leave the ambient RNG untouched.} +} +\value{ +A named list of covariance matrices (the concatenated components). +} +\description{ +Build the raw per-method data-driven covariance components + (\code{cov_canonical} / \code{cov_pca} / \code{cov_flash} / + \code{cov_flash(factors = "nonneg")}) for a \code{"strong"} SumStats set -- + the reusable building block \code{\link{mashPriorCovariances}} then refines + with an ED / udr engine. Exposed on its own so a workflow can build or + inspect a single component (the mixture-prior notebook's per-method steps) + without running the full prior. +} +\seealso{ +\code{\link{mashPriorCovariances}} +} diff --git a/man/mashInput.Rd b/man/mashInput.Rd new file mode 100644 index 00000000..2752c845 --- /dev/null +++ b/man/mashInput.Rd @@ -0,0 +1,91 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{mashInput} +\alias{mashInput} +\title{Assemble MASH strong / random / null input from S4 objects} +\usage{ +mashInput( + objects, + nRandom = 10L, + nNull = 10L, + excludeCondition = character(0), + coverage = 0.95, + zOnly = FALSE, + sigPCutoff = 1e-06, + inputScale = c("auto", "beta", "z"), + independentVariants = NULL, + seed = 999L +) +} +\arguments{ +\item{objects}{A named \code{list} of \code{\link{QtlSumStats}} and/or +\code{\link{FineMappingResult}} objects, one per region. Names disambiguate +rownames across regions (defaults to \code{region1}, \code{region2}, ...). +For \code{QtlSumStats} inputs \code{\link{summaryStatsQc}} must have been +run (the matrix builder rejects un-QC'd SumStats).} + +\item{nRandom, nNull}{Per-object random / null sample sizes (default 10 each).} + +\item{excludeCondition}{Character vector of condition (column) names to drop.} + +\item{coverage}{Credible-set coverage for \code{FineMappingResult} strong +selection (default 0.95).} + +\item{zOnly}{When \code{TRUE} the returned partitions carry only \code{.z} +(the \code{.b}/\code{.s} matrices are dropped after z is derived).} + +\item{sigPCutoff}{Significance cutoff applied to the strong partition +(default 1e-6).} + +\item{inputScale}{Matrix scale for \code{QtlSumStats} inputs +(\code{"auto"}/\code{"beta"}/\code{"z"}); ignored for \code{FineMappingResult} +(always effect-size scale).} + +\item{independentVariants}{Optional character vector of variant ids (e.g. an +LD-pruned independent SNP list). When supplied, the \emph{random} and +\emph{null} background of every object is restricted to variants that match +this set, so the background carries no LD-correlated SNPs (which would bias +the residual correlation and the mixture weights). Matching is delegated to +\code{matchVariants()} (chrom/pos/allele aware, ref/alt flips tolerated), +\emph{not} a raw string compare, so a chr-prefix / separator / allele-order +difference still matches. The \emph{strong} partition is never filtered.} + +\item{seed}{RNG seed for the random / null sampling (default 999).} +} +\value{ +A flat \code{list}: \code{strong.b}, \code{strong.s}, \code{strong.z}, + \code{random.*}, \code{null.*} (each a \code{variants x conditions} matrix) + and \code{XtX} (a \code{conditions x conditions} matrix). The \code{.b} / + \code{.s} matrices are omitted when \code{zOnly = TRUE}. +} +\description{ +Unified, S4-native replacement for the legacy +\code{load_multitrait_*_sumstat} + \code{mash_ran_null_sample} assembly. +Consumes a list of already-constructed objects (one per region) and returns +the flat \code{variants x conditions} matrix list consumed by the MASH +mixture-prior / fit / posterior steps. +} +\details{ +For EACH object three partitions are extracted: +\describe{ + \item{strong}{The high-signal variants (deterministic, class-specific). + \code{QtlSumStats}: the single most significant variant (\eqn{\max|z|}) + per condition, unioned. \code{FineMappingResult}: the lead variant + (\eqn{\max} PIP) of each credible set in each condition, unioned + (conditions with no credible set contribute nothing).} + \item{random}{\code{nRandom} variants sampled uniformly at random -- + represents the genome-wide mixture of effects and drives the mixture + weights.} + \item{null}{\code{nNull} variants sampled from those with \eqn{\max|z|<2} + -- the noise floor used to estimate the residual correlation (Vhat).} +} +Random and null are selected identically for both classes +(\code{\link{mashRandNullSample}} over the object's \code{Bhat}/\code{Shat}). +Partitions are merged across objects (rownames disambiguated by region name), +cleaned + z-derived by \code{\link{filterInvalidSummaryStat}} (\code{btoz}), +and the strong \code{XtX} cross-product appended. +} +\seealso{ +\code{\link{mashRandNullSample}}, \code{\link{mergeMashData}}, + \code{\link{filterInvalidSummaryStat}} +} diff --git a/man/mashModelFit.Rd b/man/mashModelFit.Rd new file mode 100644 index 00000000..8970332e --- /dev/null +++ b/man/mashModelFit.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashModelFit} +\alias{mashModelFit} +\title{Fit a mash Model for Posterior Computation} +\usage{ +mashModelFit( + sumStatsList, + alpha, + priorCovariances, + vhat = NULL, + fitOn = c("random", "strong"), + outputLevel = 4L, + inputScale = c("auto", "beta", "z"), + setSeed = 999 +) +} +\arguments{ +\item{sumStatsList}{Named list (or \code{S4Vectors::SimpleList}) of +\code{\link{QtlSumStats}} / \code{\link{GwasSumStats}}; must contain the +\code{fitOn} entry.} + +\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{vhat}{Residual correlation matrix (\code{V}); \code{NULL} -> identity.} + +\item{fitOn}{Partition to learn the mixture weights on: \code{"random"} +(default, the standard unbiased choice) or \code{"strong"}.} + +\item{outputLevel}{\code{mashr::mash()} \code{outputlevel} (default 4 -- the +full model \code{\link{mashPosterior}} consumes).} + +\item{inputScale}{SumStats -> matrix conversion scale.} + +\item{setSeed}{Integer seed, or \code{NULL} to leave the ambient RNG untouched.} +} +\value{ +The fitted \pkg{mashr} model (the \code{mashr::mash()} object). +} +\description{ +Fit a \pkg{mashr} model on a chosen partition using a supplied + prior covariance list and residual correlation, returning the fitted model. + This is the fit step (\code{mash_fit}'s first step): following Urbut et al. + 2019 the mixture weights are learned on the representative \code{"random"} + partition, and the resulting model is then applied to the strong / target + set by \code{\link{mashPosterior}}. +} +\seealso{ +\code{\link{mashPosterior}}, \code{\link{mashPriorCovariances}} +} diff --git a/man/mashPosterior.Rd b/man/mashPosterior.Rd new file mode 100644 index 00000000..0523b3f0 --- /dev/null +++ b/man/mashPosterior.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashPosterior} +\alias{mashPosterior} +\title{Compute mash Posterior Matrices for a Target Set} +\usage{ +mashPosterior( + model, + sumStats, + alpha, + vhat = NULL, + excludeCondition = character(0), + outputPosteriorCov = TRUE, + inputScale = c("auto", "beta", "z") +) +} +\arguments{ +\item{model}{A fitted \pkg{mashr} model (the \code{\link{mashModelFit}} +output).} + +\item{sumStats}{A single \code{\link{QtlSumStats}} / \code{\link{GwasSumStats}} +-- the target (e.g. strong) set to compute posteriors on.} + +\item{alpha}{mash \code{alpha} (match the fit).} + +\item{vhat}{Residual correlation matrix (\code{V}); \code{NULL} -> identity.} + +\item{excludeCondition}{Character vector of condition (column) names to drop +from the target AND the model before computing posteriors (the model's +covariances are resized via \code{\link{updateMashModelCov}}). Default none.} + +\item{outputPosteriorCov}{Return the full posterior covariance array (needed +by \code{\link{fitMashContrast}}). Default \code{TRUE}.} + +\item{inputScale}{SumStats -> matrix conversion scale.} +} +\value{ +The \code{mashr::mash_compute_posterior_matrices()} result: a list of + \code{PosteriorMean} / \code{PosteriorSD} / \code{lfsr} / \code{NegativeProb} + (+ \code{PosteriorCov} when \code{outputPosteriorCov = TRUE}). +} +\description{ +Apply a fitted \pkg{mashr} model (from \code{\link{mashModelFit}}) + to a target SumStats set, returning the posterior matrices + (\code{PosteriorMean}, \code{PosteriorSD}, \code{lfsr}, ...). This is the + posterior step of the mash workflow -- \code{mash_fit}'s second step and + \code{mash_posterior}'s per-analysis-unit computation. +} +\seealso{ +\code{\link{mashModelFit}}, \code{\link{fitMashContrast}} +} diff --git a/man/mashPosteriorContrast.Rd b/man/mashPosteriorContrast.Rd new file mode 100644 index 00000000..592be75b --- /dev/null +++ b/man/mashPosteriorContrast.Rd @@ -0,0 +1,40 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashPosteriorContrast} +\alias{mashPosteriorContrast} +\title{Posterior contrast table over an entire mash posterior} +\usage{ +mashPosteriorContrast(posteriorMean, posteriorVcov, origMean, grouping = NULL) +} +\arguments{ +\item{posteriorMean}{Numeric matrix (features x conditions) of posterior +means (\code{PosteriorMean} from \code{\link{mashPosterior}}).} + +\item{posteriorVcov}{Numeric array (conditions x conditions x features) of +posterior covariances (\code{PosteriorCov}).} + +\item{origMean}{Numeric matrix (features x conditions) of the original +effect estimates (e.g. \code{bhat}); used to decide which conditions were +tested per feature. Aligned to \code{posteriorMean}'s columns by name; +\code{NaN} is treated as 0 (untested).} + +\item{grouping}{Optional named integer vector assigning conditions to groups +(0 = independent); forwarded to \code{\link{fitMashContrast}} so replicate +populations of one cell type share weight. Names are condition labels.} +} +\value{ +A \code{data.frame} (features x contrasts) with + \code{mean_contrast_*}, \code{se_contrast_*}, \code{p_contrast_*} columns + and feature ids as row names. Empty when nothing is testable. +} +\description{ +Orchestrates \code{\link{fitMashContrast}} across every feature (variant) +of a mash posterior: aligns the original effect matrix to the posterior +columns, runs the per-feature deviation + pairwise contrast, row-binds the +results (aligning the union of contrast columns), and orders them +(\code{mean}/\code{se}/\code{p}, deviation before pairwise). Features with +fewer than two tested conditions are dropped. +} +\seealso{ +\code{\link{fitMashContrast}}, \code{\link{metaAnalysisPerCondition}} +} diff --git a/man/mashPriorCovariances.Rd b/man/mashPriorCovariances.Rd new file mode 100644 index 00000000..da4e59c2 --- /dev/null +++ b/man/mashPriorCovariances.Rd @@ -0,0 +1,81 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashPriorCovariances} +\alias{mashPriorCovariances} +\title{Estimate mash Prior Covariances and Mixture Weights} +\usage{ +mashPriorCovariances( + sumStatsList, + alpha, + vhat = NULL, + components = c("canonical", "pca", "flash", "flash_nonneg"), + engine = c("cov_ed", "ud", "ud_ted"), + nPcs = NULL, + priorCovariances = NULL, + priorComponents = NULL, + udControl = list(), + inputScale = c("auto", "beta", "z"), + setSeed = 999 +) +} +\arguments{ +\item{sumStatsList}{Named list (or \code{S4Vectors::SimpleList}) with at least +\code{"strong"} (the discovery set the covariances are learned on).} + +\item{alpha}{mash \code{alpha}.} + +\item{vhat}{Residual correlation matrix (\code{V}); typically from +\code{\link{mashResidualCorrelation}}. \code{NULL} -> identity.} + +\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 = +"nonneg")}). Built in that fixed order. Ignored by the \code{"ud"} / +\code{"ud_ted"} engines.} + +\item{engine}{Covariance-refinement engine. \code{"cov_ed"} (default; mashr's +exported \code{cov_ed()} extreme deconvolution, whose default +\code{algorithm = "bovy"} IS the Bovy et al. 2011 method -- weights from a +final \code{mash()}); \code{"ud"} / \code{"ud_ted"} (\pkg{udr} ED / TED +updates, returning weights directly -- OPT-IN, known numerical issues, so +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.} + +\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 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 \code{priorCovariances}, which bypasses the engine entirely.} + +\item{udControl}{Named list overriding the \pkg{udr} controls for the +\code{"ud"} / \code{"ud_ted"} engines: \code{n_unconstrained} (data-driven +matrices to fit; default 50 -- the dominant cost, so reduce it for +few-condition data), \code{maxiter} (default 1000), \code{tol}, +\code{tol.lik}. Ignored by \code{cov_ed}.} + +\item{inputScale}{SumStats -> matrix conversion scale.} + +\item{setSeed}{Integer seed, or \code{NULL} to leave the ambient RNG untouched.} +} +\value{ +\code{list(U, w, loglik)}: the covariance list, the + \code{mashr::get_estimated_pi()} mixture weights, and the fit + log-likelihood (\code{NULL} for the \code{cov_ed} engine). +} +\description{ +Build the mash prior covariance list \code{U} and mixture weights + \code{w} from a \code{{strong[, random, null]}} SumStats 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 (\code{cov_ed}). +} +\seealso{ +\code{\link{mashPipeline}}, \code{\link{mashResidualCorrelation}} +} diff --git a/man/mashResidualCorrelation.Rd b/man/mashResidualCorrelation.Rd new file mode 100644 index 00000000..cb5d83df --- /dev/null +++ b/man/mashResidualCorrelation.Rd @@ -0,0 +1,60 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{mashResidualCorrelation} +\alias{mashResidualCorrelation} +\title{Estimate the mash Residual Correlation Matrix (Vhat)} +\usage{ +mashResidualCorrelation( + sumStatsList, + alpha, + method = c("simple", "identity", "mle", "corshrink", "simple_specific"), + priorCovariances = NULL, + nSubset = 6000L, + maxIter = 6L, + inputScale = c("auto", "beta", "z"), + setSeed = 999 +) +} +\arguments{ +\item{sumStatsList}{Named list (or \code{S4Vectors::SimpleList}) of +\code{\link{QtlSumStats}} / \code{\link{GwasSumStats}}. \code{method = +"simple"} needs a \code{"null"} entry; \code{method = "mle"} needs +\code{"random"}; \code{method = "identity"} reads only the condition count +off \code{"strong"}.} + +\item{alpha}{mash \code{alpha} (forwarded to \code{mashr::mash_set_data()}).} + +\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{"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"}).} + +\item{nSubset, maxIter}{\code{method = "mle"} controls (random-subset size and +EM iterations).} + +\item{inputScale}{SumStats -> matrix conversion scale (\code{"auto"} / +\code{"beta"} / \code{"z"}).} + +\item{setSeed}{Integer seed, or \code{NULL} to leave the ambient RNG stream +untouched (how \code{mashPipeline} keeps one continuous stream across its +delegated calls).} +} +\value{ +A conditions x conditions residual correlation matrix. +} +\description{ +Estimate the residual (null) correlation matrix \eqn{\hat V} that + \code{mashr::mash_set_data()} consumes as \code{V}. Split out of + \code{\link{mashPipeline}} so the estimation logic lives in one place and is + reusable by the mixture-prior workflows. +} +\seealso{ +\code{\link{mashPipeline}}, \code{\link{mashPriorCovariances}} +} diff --git a/man/metaAnalysisPerCell.Rd b/man/metaAnalysisPerCell.Rd deleted file mode 100644 index 09906243..00000000 --- a/man/metaAnalysisPerCell.Rd +++ /dev/null @@ -1,39 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/mashPipeline.R -\name{metaAnalysisPerCell} -\alias{metaAnalysisPerCell} -\title{Random-Effects Meta-Analysis of Mash Pairwise Contrasts} -\usage{ -metaAnalysisPerCell(effectSizes, seValues, seCutoff = 0) -} -\arguments{ -\item{effectSizes}{Numeric matrix (features x conditions) of contrast -effect sizes. Column names must follow the pattern -\code{mean_contrast__vs_}.} - -\item{seValues}{Numeric matrix (features x conditions) of contrast -standard errors. Must have the same dimensions and column names as -\code{effectSizes}.} - -\item{seCutoff}{Numeric; minimum SE below which a condition is excluded -from the meta-analysis for a given feature (default 0).} -} -\value{ -A tibble with columns: - \describe{ - \item{cell}{Cell type name.} - \item{condition}{Original pairwise contrast name (without prefix).} - \item{meta_pvalue}{P-value from the random-effects meta-analysis.} - \item{meta_effect}{Pooled absolute effect size estimate.} - \item{meta_se}{Standard error of the pooled estimate.} - \item{tau2}{Between-study variance estimate.} - \item{I2}{Heterogeneity measure (proportion of variance due to - between-study variance), in [0, 1].} - } -} -\description{ -For each cell type (condition), gathers all pairwise contrast effect -sizes and standard errors involving that cell, then runs a -DerSimonian–Laird random-effects meta-analysis per condition. -Intended to be run on the output of \code{\link{fitMashContrast}}. -} diff --git a/man/metaAnalysisPerCondition.Rd b/man/metaAnalysisPerCondition.Rd new file mode 100644 index 00000000..cd011eaf --- /dev/null +++ b/man/metaAnalysisPerCondition.Rd @@ -0,0 +1,51 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{metaAnalysisPerCondition} +\alias{metaAnalysisPerCondition} +\title{Random-Effects Meta-Analysis of Mash Pairwise Contrasts, per Condition} +\usage{ +metaAnalysisPerCondition( + effectSizes, + seValues, + seCutoff = 0, + metaMethod = "DL" +) +} +\arguments{ +\item{effectSizes}{Numeric matrix (features x contrasts) of contrast +effect sizes. Column names must follow the pattern +\code{mean_contrast__vs_}.} + +\item{seValues}{Numeric matrix (features x contrasts) of contrast +standard errors. Must have the same dimensions and column names as +\code{effectSizes}.} + +\item{seCutoff}{Numeric; minimum SE below which a contrast is excluded +from the meta-analysis for a given feature (default 0).} + +\item{metaMethod}{Between-study variance estimator for the random-effects +meta-analysis, forwarded to \code{metafor::rma(method = )}. Default +\code{"DL"} (DerSimonian-Laird); other options include \code{"REML"}, +\code{"ML"}, \code{"EB"}.} +} +\value{ +A tibble with columns: + \describe{ + \item{condition}{The condition (context) name.} + \item{contrast}{Pairwise contrast name (without prefix), e.g. + \code{conditionA_vs_conditionB}.} + \item{meta_pvalue}{P-value from the random-effects meta-analysis.} + \item{meta_effect}{Pooled absolute effect size estimate.} + \item{meta_se}{Standard error of the pooled estimate.} + \item{tau2}{Between-study variance estimate.} + \item{I2}{Heterogeneity measure (proportion of variance due to + between-study variance), in [0, 1].} + } +} +\description{ +For each condition (context), gathers all pairwise contrast effect sizes and +standard errors involving that condition, then runs a random-effects +meta-analysis (via \code{metafor::rma}; pecotmr does not implement its own +meta-analysis). Intended to be run on the output of +\code{\link{fitMashContrast}} / \code{\link{mashPosteriorContrast}}. +} diff --git a/man/metaRandomEffects.Rd b/man/metaRandomEffects.Rd deleted file mode 100644 index dec4f440..00000000 --- a/man/metaRandomEffects.Rd +++ /dev/null @@ -1,30 +0,0 @@ -% Generated by roxygen2: do not edit by hand -% Please edit documentation in R/h2EstimationWrappers.R -\name{metaRandomEffects} -\alias{metaRandomEffects} -\title{Random-Effects Meta-Analysis (DerSimonian-Laird)} -\usage{ -metaRandomEffects(means, ses) -} -\arguments{ -\item{means}{Numeric vector of study-level point estimates.} - -\item{ses}{Numeric vector of study-level standard errors (must be -positive and finite).} -} -\value{ -A list with: - \describe{ - \item{mean}{Pooled meta-analytic mean.} - \item{se}{Standard error of the pooled mean.} - \item{tau2}{Estimated between-study variance.} - \item{I2}{Higgins I-squared heterogeneity statistic (proportion of - total variance due to between-study variance), in [0, 1].} - \item{Q}{Cochran's Q statistic for heterogeneity.} - } -} -\description{ -Perform a DerSimonian-Laird random-effects meta-analysis - from a set of study-level point estimates and standard errors. -} -\keyword{internal} diff --git a/man/metaSldscRandom.Rd b/man/metaSldscRandom.Rd index 0b548d65..27432efe 100644 --- a/man/metaSldscRandom.Rd +++ b/man/metaSldscRandom.Rd @@ -22,8 +22,9 @@ metaSldscRandom( List with `mean`, `se`, `p`, `nTraits`, `traitsUsed`, `tau2`. } \description{ -DerSimonian-Laird random-effects meta-analysis of one S-LDSC - quantity for one annotation across multiple traits. +Random-effects meta-analysis (DerSimonian-Laird, via + \code{metafor::rma}) of one S-LDSC quantity for one annotation across + multiple traits. } \details{ Per-trait \eqn{SE_i} sources: diff --git a/man/multitraite_data.Rd b/man/multitrait_data.Rd similarity index 93% rename from man/multitraite_data.Rd rename to man/multitrait_data.Rd index ade7f51b..6a578bc8 100644 --- a/man/multitraite_data.Rd +++ b/man/multitrait_data.Rd @@ -1,11 +1,11 @@ % Generated by roxygen2: do not edit by hand % Please edit documentation in R/exampleData.R \docType{data} -\name{multitraite_data} -\alias{multitraite_data} +\name{multitrait_data} +\alias{multitrait_data} \title{Simulated Multi-condition Data for TWAS analysis} \format{ -\code{multitraite_data} is a list with the following elements: +\code{multitrait_data} is a list with the following elements: \describe{ @@ -45,7 +45,7 @@ TWAS analysis. Genotype matrix is centered and scaled, expression matrix is normalized. } \examples{ -data(multitraite_data) +data(multitrait_data) } \references{ diff --git a/man/nSignificantScore.Rd b/man/nSignificantScore.Rd new file mode 100644 index 00000000..0fbd478f --- /dev/null +++ b/man/nSignificantScore.Rd @@ -0,0 +1,23 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{nSignificantScore} +\alias{nSignificantScore} +\title{Feature score from the fraction of significant deviation contrasts} +\usage{ +nSignificantScore(contrastResult, pCutoff = 1e-05) +} +\arguments{ +\item{contrastResult}{A contrast table from \code{\link{mashPosteriorContrast}} +carrying \code{p_contrast_*_deviation} columns.} + +\item{pCutoff}{Significance threshold (default 1e-5).} +} +\value{ +A \code{data.frame} with \code{condition} and \code{ratio} + (\eqn{n_{sig} / n}). +} +\description{ +For each condition's deviation contrast, the proportion of variants whose +contrast p-value falls below \code{pCutoff} -- the "n-significant" feature +score of \code{mash_posterior.ipynb}. No meta-analysis is involved. +} diff --git a/man/overlapTopLoci.Rd b/man/overlapTopLoci.Rd new file mode 100644 index 00000000..7e336750 --- /dev/null +++ b/man/overlapTopLoci.Rd @@ -0,0 +1,50 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/overlapTopLoci.R +\name{overlapTopLoci} +\alias{overlapTopLoci} +\alias{overlapTopLoci,QtlFineMappingResult,GwasFineMappingResult-method} +\title{Overlap QTL and GWAS top loci by allele-aware variant matching} +\usage{ +overlapTopLoci(qtl, gwas, ...) + +\S4method{overlapTopLoci}{QtlFineMappingResult,GwasFineMappingResult}( + qtl, + gwas, + signalCutoff = 0.025, + type = c("data.frame", "GRanges"), + ... +) +} +\arguments{ +\item{qtl}{A \code{QtlFineMappingResult}.} + +\item{gwas}{A \code{GwasFineMappingResult}.} + +\item{...}{Ignored.} + +\item{signalCutoff}{PIP cutoff forwarded to \code{\link{getTopLoci}} for both +inputs. Default 0.025.} + +\item{type}{\code{"data.frame"} (default) or \code{"GRanges"}.} +} +\value{ +A \code{data.frame} (or \code{GRanges}) keyed on the QTL variant + (\code{variant_id, chrom, pos, A1, A2}) with all other columns prefixed + \code{qtl_} / \code{gwas_}. Zero rows when there is no allele-aware overlap. +} +\description{ +Intersect the top-loci tables of a \code{QtlFineMappingResult} and a +\code{GwasFineMappingResult} on shared variants, matched with pecotmr's +allele-aware \code{\link{matchVariants}} (handling strand flips / ref-alt +swaps rather than naive id equality). The GWAS side is harmonized to the QTL +orientation: its signed effect columns (\code{beta}, \code{z}, +\code{conditional_effect}) are sign-flipped and its effect-allele frequency +(\code{af}) is complemented wherever a swap occurred. The result keeps the +variant key columns once (from the QTL, the reference orientation) and +prefixes every other column \code{qtl_} / \code{gwas_}. A variant shared +across several QTL contexts and/or GWAS studies yields one row per +(QTL entry x GWAS entry) pair (a wide cross-product per variant). +} +\seealso{ +\code{\link{getTopLoci}}, \code{\link{matchVariants}} +} diff --git a/man/postprocessFinemappingFits.Rd b/man/postprocessFinemappingFits.Rd index 8aa69cd5..f4733629 100644 --- a/man/postprocessFinemappingFits.Rd +++ b/man/postprocessFinemappingFits.Rd @@ -21,7 +21,10 @@ postprocessFinemappingFits( medianAbsCorr = NULL, csInput = NULL, conditionIdx = NULL, - trim = TRUE + trim = TRUE, + fullFit = FALSE, + fullFitAlphaOnly = TRUE, + includeAllCs = FALSE ) } \arguments{ @@ -57,7 +60,7 @@ MAF). Default NULL.} A list with \code{finemappingResults} (per-method post-processed objects, each carrying a trimmed fit and method-specific intermediates) and a single unified \code{top_loci} table in the fixed 22-column shape - (see \code{\link{buildTopLoci}}). Per-method contributions are + (see the internal \code{buildTopLoci}). Per-method contributions are row-bound into \code{top_loci} by an outer method for-loop. } \description{ diff --git a/man/qtlAssociationPostprocess.Rd b/man/qtlAssociationPostprocess.Rd new file mode 100644 index 00000000..0db5873e --- /dev/null +++ b/man/qtlAssociationPostprocess.Rd @@ -0,0 +1,53 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/AllGenerics.R, R/qtlAssociationPostprocess.R +\name{qtlAssociationPostprocess} +\alias{qtlAssociationPostprocess} +\alias{qtlAssociationPostprocess,QtlSumStats-method} +\title{Hierarchical Multiple-Testing Correction for cis-QTL Association} +\usage{ +qtlAssociationPostprocess(x, ...) + +\S4method{qtlAssociationPostprocess}{QtlSumStats}( + x, + fdrThreshold = 0.05, + mafCutoff = 0, + cisWindow = 0, + methods = c("permutation", "bonferroni"), + pvalueCol = "P", + afCol = "af" +) +} +\arguments{ +\item{x}{A \code{QtlSumStats}.} + +\item{...}{Correction arguments.} + +\item{fdrThreshold}{Event- and variant-level FDR threshold (default 0.05).} + +\item{mafCutoff}{Minor-allele-frequency cutoff for the FILTERED Bonferroni +flavour (fold of the per-variant \code{af} mcol). \code{0} disables it.} + +\item{cisWindow}{cis-window (bp) for the FILTERED Bonferroni flavour, applied +to the per-variant \code{tss_distance}/\code{tes_distance} mcols. \code{0} +disables it. When either \code{mafCutoff} or \code{cisWindow} is > 0 the +\code{*_filtered} columns are produced (requires the \code{n_variants_filtered} +row column).} + +\item{methods}{Correction families to compute: any of \code{"permutation"} +(needs \code{p_beta}/\code{beta_shape1}/\code{beta_shape2}) and +\code{"bonferroni"} (needs \code{n_variants}). The q-value SNP method adds +no stored column -- it is a significance query (see \code{getSignificantQtls}).} + +\item{pvalueCol, afCol}{Entry mcol names for the per-variant p-value / allele +frequency (defaults \code{"P"} / \code{"af"}).} +} +\value{ +The input \code{QtlSumStats} with added correction columns. +} +\description{ +Apply hierarchical (local per-gene + global across-gene) + multiple-testing correction to a per-gene \code{QtlSumStats} of cis-QTL + association statistics (one row per gene/trait), returning the same object + enriched with the corrected-statistic columns. See + \code{\link{qtlAssociationPostprocess}}. +} diff --git a/man/qtlSumStatsFromBetaMatrix.Rd b/man/qtlSumStatsFromBetaMatrix.Rd new file mode 100644 index 00000000..aa93293d --- /dev/null +++ b/man/qtlSumStatsFromBetaMatrix.Rd @@ -0,0 +1,61 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashWrapper.R +\name{qtlSumStatsFromBetaMatrix} +\alias{qtlSumStatsFromBetaMatrix} +\title{Build a QtlSumStats from Bhat / Shat (effect-size) Matrices} +\usage{ +qtlSumStatsFromBetaMatrix( + bhat, + shat, + study, + ldSketch = NULL, + context = colnames(bhat), + trait = "mash", + genome = "GRCh38", + n = 1000L, + a1 = "A", + a2 = "G", + role = "mash" +) +} +\arguments{ +\item{bhat}{Numeric matrix (variants x conditions) of effect sizes. +\code{rownames(bhat)} are variant ids; \code{colnames(bhat)} label the +conditions.} + +\item{shat}{Numeric matrix of standard errors, aligned with \code{bhat} +(identical dimensions and row/column order).} + +\item{study}{Study identifier (recycled across conditions).} + +\item{ldSketch}{A \code{\link{GenotypeHandle}} embedded in the collection, or +\code{NULL} (default) -- mash operates across conditions per variant and +needs no LD reference.} + +\item{context, trait}{Condition labels; see \code{\link{qtlSumStatsFromZMatrix}}. +Defaults \code{context = colnames(bhat)}, \code{trait = "mash"}.} + +\item{genome}{Genome build. Default \code{"GRCh38"}.} + +\item{n}{Placeholder per-variant sample size. Default \code{1000}.} + +\item{a1, a2}{Placeholder alleles. Defaults \code{"A"} / \code{"G"}.} + +\item{role}{Tag stored in the \code{qcInfo} record. Default \code{"mash"}.} +} +\value{ +A \code{\link{QtlSumStats}} with one entry per condition (column). +} +\description{ +Assemble a per-condition \code{\link{QtlSumStats}} from an aligned + pair of \code{variants x conditions} effect-size (\code{Bhat}) and + standard-error (\code{Shat}) matrices -- the beta-scale (EE) counterpart of + \code{\link{qtlSumStatsFromZMatrix}}. Each entry carries \code{BETA}, + \code{SE}, and (derived) \code{Z = BETA / SE} mcols, so the result feeds + \code{\link{mashPipeline}} / \code{\link{mashModelFit}} on either scale + (\code{inputScale = "beta"} or \code{"z"}). Chromosome / position are decoded + from the row (variant) ids exactly as in \code{\link{qtlSumStatsFromZMatrix}}. +} +\seealso{ +\code{\link{qtlSumStatsFromZMatrix}}, \code{\link{mashModelFit}} +} diff --git a/man/qtlSumStatsFromZMatrix.Rd b/man/qtlSumStatsFromZMatrix.Rd index 4bc1d80b..e37ed4c0 100644 --- a/man/qtlSumStatsFromZMatrix.Rd +++ b/man/qtlSumStatsFromZMatrix.Rd @@ -7,7 +7,7 @@ qtlSumStatsFromZMatrix( z, study, - ldSketch, + ldSketch = NULL, context = colnames(z), trait = "mash", genome = "GRCh38", @@ -24,7 +24,9 @@ conditions.} \item{study}{Study identifier (recycled across conditions).} -\item{ldSketch}{A \code{\link{GenotypeHandle}} embedded in the collection.} +\item{ldSketch}{A \code{\link{GenotypeHandle}} embedded in the collection, or +\code{NULL} (default) -- mash operates across conditions per variant and +needs no LD reference.} \item{context}{Condition context label(s): a single value recycled across every column, or a length-\code{ncol(z)} vector (one per condition). diff --git a/man/scoreFromCs.Rd b/man/scoreFromCs.Rd new file mode 100644 index 00000000..024712c6 --- /dev/null +++ b/man/scoreFromCs.Rd @@ -0,0 +1,29 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/mashPipeline.R +\name{scoreFromCs} +\alias{scoreFromCs} +\title{Feature score from fine-mapped credible sets} +\usage{ +scoreFromCs(fineMapping, contrastResults, condition) +} +\arguments{ +\item{fineMapping}{A fine-mapping \code{data.frame} with \code{cs_order}, +\code{pip} and \code{variants} columns (credible-set index 0 = not in a CS).} + +\item{contrastResults}{A contrast table from +\code{\link{mashPosteriorContrast}} with variant row names.} + +\item{condition}{Condition label whose deviation p-value column is used; if +that column is absent and exactly one pairwise contrast exists, the +pairwise p-value is used instead.} +} +\value{ +A single numeric score, or \code{NA} when nothing overlaps. +} +\description{ +Scores a condition using a fine-mapping table: takes the lead (max-PIP) +variant of each credible set, intersects with the contrast variants, picks +the least-significant lead by deviation p-value, and returns the maximum +pairwise \eqn{|\mathrm{mean}| / \mathrm{se}} at that variant -- the "finemap" +feature score of \code{mash_posterior.ipynb}. +} diff --git a/man/sldscSubsetMeta.Rd b/man/sldscSubsetMeta.Rd index 6db9b363..8cc68e02 100644 --- a/man/sldscSubsetMeta.Rd +++ b/man/sldscSubsetMeta.Rd @@ -24,7 +24,8 @@ A list with \code{tau_star_single}, \code{tau_star_joint}, of \code{\link{metaSldscRandom}} results. } \description{ -Re-run the DerSimonian-Laird random-effects meta-analysis on a chosen subset +Re-run the random-effects meta-analysis (DerSimonian-Laird, via +\code{metafor::rma}) on a chosen subset of the per-trait standardised tables produced by \code{\link{sldscPostprocessingPipeline}} -- no regression is re-run, only the already-standardised per-trait estimates are re-meta'd. Powers a "meta on a diff --git a/man/subsetChr.Rd b/man/subsetChr.Rd index 11a500e0..ee724c6b 100644 --- a/man/subsetChr.Rd +++ b/man/subsetChr.Rd @@ -1,17 +1,17 @@ % Generated by roxygen2: do not edit by hand -% Please edit documentation in R/AllGenerics.R, R/gwasSumStats.R, -% R/qtlSumStats.R +% Please edit documentation in R/AllGenerics.R, R/qtlSumStats.R, +% R/gwasSumStats.R \name{subsetChr} \alias{subsetChr} -\alias{subsetChr,GwasSumStats-method} \alias{subsetChr,QtlSumStats-method} +\alias{subsetChr,GwasSumStats-method} \title{Subset by Chromosome} \usage{ subsetChr(x, chr) -\S4method{subsetChr}{GwasSumStats}(x, chr) - \S4method{subsetChr}{QtlSumStats}(x, chr) + +\S4method{subsetChr}{GwasSumStats}(x, chr) } \arguments{ \item{x}{A \code{GwasSumStats} object.} diff --git a/pixi.toml b/pixi.toml index 419b6bee..1739ffb2 100644 --- a/pixi.toml +++ b/pixi.toml @@ -43,7 +43,6 @@ r45 = {features = ["r45"]} "r-testthat" = "*" "r-tidyverse" = "*" "bioconductor-biocparallel" = "*" -"bioconductor-biostrings" = "*" "bioconductor-genomicranges" = "*" "bioconductor-iranges" = "*" "bioconductor-qvalue" = "*" @@ -62,6 +61,7 @@ r45 = {features = ["r45"]} "r-coda" = "*" "r-coloc" = "*" "r-colocboost" = "*" +"r-corshrink" = "*" "r-cpp11" = "*" "r-cpp11armadillo" = "*" "r-ctwas" = "*" @@ -78,6 +78,7 @@ r45 = {features = ["r45"]} "r-mashr" = "*" "r-matrix" = "*" "r-matrixstats" = "*" +"r-metafor" = "*" "r-mr.ash.alpha" = "*" "r-mr.mashr" = "*" "r-mvsusier" = "*" @@ -100,6 +101,7 @@ r45 = {features = ["r45"]} "r-tibble" = "*" "r-tictoc" = "*" "r-tidyr" = "*" +"r-udr" = "*" "r-vctrs" = "*" "r-vroom" = "*" "r-xgboost" = "*" diff --git a/src/Makevars.in b/src/Makevars similarity index 100% rename from src/Makevars.in rename to src/Makevars diff --git a/tests/testthat/test_AnnotationMatrix.R b/tests/testthat/test_AnnotationMatrix.R new file mode 100644 index 00000000..72385da8 --- /dev/null +++ b/tests/testthat/test_AnnotationMatrix.R @@ -0,0 +1,133 @@ +context("AnnotationMatrix") + +# Migrated from test_h2Annotations.R: the AnnotationMatrix S4 class + validity, +# its constructor, the getAnnotations/getAnnotationMeta/getSnpRanges/getGenome +# accessors, and the getBaseline / getCandidates tier accessors — all now +# defined in R/AnnotationMatrix.R. Annotation *readers* stay in +# test_h2Annotations.R. Fixtures come from helper-h2Classes.R. + +test_that("AnnotationMatrix validates dimensions and meta", { + gr <- make_test_granges(10) + meta <- make_test_annotation_meta() + mat <- matrix(0, nrow = 10, ncol = 3) + + obj <- AnnotationMatrix(mat, gr, meta) + expect_s4_class(obj, "AnnotationMatrix") + expect_true(methods::validObject(obj)) +}) + +test_that("AnnotationMatrix rejects row mismatch", { + gr <- make_test_granges(10) + meta <- make_test_annotation_meta() + mat <- matrix(0, nrow = 5, ncol = 3) # wrong number of rows + + expect_error(AnnotationMatrix(mat, gr, meta), "rows.*must match") +}) + +test_that("AnnotationMatrix rejects column mismatch with meta", { + gr <- make_test_granges(10) + meta <- make_test_annotation_meta() # 3 annotations + mat <- matrix(0, nrow = 10, ncol = 2) # only 2 columns + + # Constructor errors when colnames assignment fails (dimnames mismatch) + expect_error(AnnotationMatrix(mat, gr, meta)) +}) + +test_that("AnnotationMatrix rejects invalid tier values", { + gr <- make_test_granges(10) + meta <- data.frame( + name = "x", tier = "invalid_tier", type = "binary", + stringsAsFactors = FALSE) + mat <- matrix(0, nrow = 10, ncol = 1) + + expect_error(AnnotationMatrix(mat, gr, meta), "tier.*baseline.*candidate") +}) + +test_that("AnnotationMatrix rejects invalid type values", { + gr <- make_test_granges(10) + meta <- data.frame( + name = "x", tier = "baseline", type = "ordinal", + stringsAsFactors = FALSE) + mat <- matrix(0, nrow = 10, ncol = 1) + + expect_error(AnnotationMatrix(mat, gr, meta), "type.*binary.*continuous") +}) + +test_that("AnnotationMatrix() constructor creates object from matrix", { + n <- 10 + gr <- make_test_granges(n) + meta <- make_test_annotation_meta() + mat <- matrix(runif(n * 3), nrow = n, ncol = 3) + + obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") + expect_s4_class(obj, "AnnotationMatrix") + expect_equal(nrow(obj@annotations), n) + expect_equal(ncol(obj@annotations), 3) + expect_equal(obj@genome, "hg38") +}) + +test_that("AnnotationMatrix() sets column names from annotation_meta", { + n <- 10 + gr <- make_test_granges(n) + meta <- make_test_annotation_meta() + mat <- matrix(0, nrow = n, ncol = 3) # No colnames set on mat + + obj <- AnnotationMatrix(mat, gr, meta) + expect_equal(colnames(obj@annotations), c("base", "enhancer", "promoter")) +}) + +test_that("AnnotationMatrix rejects a non-data.frame annotationMeta", { + gr <- make_test_granges(10) + expect_error( + AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = list(a = 1)), + "annotationMeta must be a data.frame") +}) + +test_that("AnnotationMatrix rejects annotationMeta missing required columns", { + gr <- make_test_granges(10) + bad_meta <- data.frame(foo = c("a", "b", "c"), stringsAsFactors = FALSE) + expect_error( + AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = bad_meta), + "must have columns: name, tier, type") +}) + +test_that("AnnotationMatrix accessors round-trip the stored slots", { + n <- 10 + gr <- make_test_granges(n) + meta <- make_test_annotation_meta() + mat <- matrix(runif(n * 3), nrow = n, ncol = 3) + obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") + + expect_equal(dim(getAnnotations(obj)), c(n, 3L)) + expect_equal(getAnnotationMeta(obj), meta) + expect_equal(getSnpRanges(obj), gr) + expect_equal(getGenome(obj), "hg38") +}) + +test_that("getBaseline() subsets to baseline-tier only", { + n <- 10 + gr <- make_test_granges(n) + meta <- make_test_annotation_meta() # 1 baseline, 2 candidate + mat <- matrix(0, nrow = n, ncol = 3) + + obj <- AnnotationMatrix(mat, gr, meta) + baseline <- getBaseline(obj) + + expect_s4_class(baseline, "AnnotationMatrix") + expect_equal(ncol(baseline@annotations), 1) + expect_true(all(baseline@annotationMeta$tier == "baseline")) +}) + +test_that("getCandidates() subsets to candidate-tier only", { + n <- 10 + gr <- make_test_granges(n) + meta <- make_test_annotation_meta() # 1 baseline, 2 candidate + mat <- matrix(0, nrow = n, ncol = 3) + + obj <- AnnotationMatrix(mat, gr, meta) + cand <- getCandidates(obj) + + expect_s4_class(cand, "AnnotationMatrix") + expect_equal(ncol(cand@annotations), 2) + expect_true(all(cand@annotationMeta$tier == "candidate")) +}) diff --git a/tests/testthat/test_CtwasResult.R b/tests/testthat/test_CtwasResult.R index 737923dd..65481d15 100644 --- a/tests/testthat/test_CtwasResult.R +++ b/tests/testthat/test_CtwasResult.R @@ -1,4 +1,7 @@ -context("CtwasResult / CtwasResultEntry") +context("CtwasResult") + +# CtwasResultEntry (the per-row payload class) is tested in +# test_CtwasResultEntry.R; this file covers the CtwasResult collection. .cr_entry <- function(ids = c("g1", "g2"), pip = c(0.9, 0.1), prior = NULL) { CtwasResultEntry( @@ -8,17 +11,6 @@ context("CtwasResult / CtwasResultEntry") regionInfo = data.frame(region_id = "r1", stringsAsFactors = FALSE)) } -test_that("CtwasResultEntry: constructor + accessors round-trip", { - e <- .cr_entry(prior = list(group_prior = c(brain = 0.01))) - expect_s4_class(e, "CtwasResultEntry") - expect_equal(nrow(getFinemap(e)), 2L) - expect_equal(nrow(getSusieAlpha(e)), 2L) - expect_equal(getCtwasParam(e)$group_prior, c(brain = 0.01)) - # empty entry is valid; accessors return NULL - expect_null(getFinemap(CtwasResultEntry())) - expect_null(getSusieAlpha(CtwasResultEntry())) -}) - test_that("CtwasResult: constructor keyed by (gwasStudy, study, context, method)", { cr <- CtwasResult( gwasStudy = c("D1", "D1"), study = c("Q1", "Q1"), diff --git a/tests/testthat/test_CtwasResultEntry.R b/tests/testthat/test_CtwasResultEntry.R new file mode 100644 index 00000000..c497bba1 --- /dev/null +++ b/tests/testthat/test_CtwasResultEntry.R @@ -0,0 +1,27 @@ +context("CtwasResultEntry") + +# Migrated from test_CtwasResult.R: the per-run cTWAS payload class (constructor +# + getFinemap / getSusieAlpha / getCtwasParam accessors). The CtwasResult +# collection tests live in test_CtwasResult.R. + +test_that("CtwasResultEntry: constructor + accessors round-trip", { + e <- CtwasResultEntry( + finemap = data.frame(id = c("g1", "g2"), susie_pip = c(0.9, 0.1), + stringsAsFactors = FALSE), + susieAlpha = data.frame(id = c("g1", "g2"), susie_alpha = c(0.9, 0.1), + stringsAsFactors = FALSE), + param = list(group_prior = c(brain = 0.01)), + regionInfo = data.frame(region_id = "r1", stringsAsFactors = FALSE)) + expect_s4_class(e, "CtwasResultEntry") + expect_equal(nrow(getFinemap(e)), 2L) + expect_equal(nrow(getSusieAlpha(e)), 2L) + expect_equal(getCtwasParam(e)$group_prior, c(brain = 0.01)) +}) + +test_that("CtwasResultEntry: an empty entry is valid and its accessors return NULL", { + e <- CtwasResultEntry() + expect_s4_class(e, "CtwasResultEntry") + expect_null(getFinemap(e)) + expect_null(getSusieAlpha(e)) + expect_null(getCtwasParam(e)) +}) diff --git a/tests/testthat/test_FineMappingEntry.R b/tests/testthat/test_FineMappingEntry.R index fd02318c..deef6d82 100644 --- a/tests/testthat/test_FineMappingEntry.R +++ b/tests/testthat/test_FineMappingEntry.R @@ -362,4 +362,28 @@ test_that("FineMappingEntry: adjustPips subsets mu2 and recomputes posterior_sd" expect_true(all(adj@topLoci$posterior_sd >= 0)) }) +test_that("getCs / getTopLoci minPurity filters CS by purity, independent of coverage + pip", { + # Two 0.95 credible sets: CS1 (v1,v2) pure (0.9), CS2 (v3,v4) impure (0.3); v5 non-CS. + vn <- paste0("chr1:", (1:5) * 100, ":A:G") + L <- 2L; P <- 5L + alpha <- matrix(0.1, L, P); alpha[1, 1:2] <- c(0.5, 0.4); alpha[2, 3:4] <- c(0.5, 0.4) + fit <- list(alpha = alpha, mu = matrix(0.3, L, P), mu2 = matrix(1.2, L, P), + pip = c(0.6, 0.5, 0.4, 0.4, 0.02)) + class(fit) <- "susie" + cst <- list(list(sets = list(cs = list(L1 = c(1L, 2L), L2 = c(3L, 4L)), + purity = data.frame(min.abs.corr = c(0.9, 0.3)))), + list(sets = list(cs = list())), list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.70, 0.50) + tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") + e <- FineMappingEntry(variantIds = vn, susieFit = fit, topLoci = tl) + + # getCs: minPurity is orthogonal to coverage -> keeps only the pure CS members + expect_equal(nrow(getCs(e, coverage = 0.95)), 4L) + expect_equal(getCs(e, coverage = 0.95, minPurity = 0.8)$variant_id, vn[1:2]) + # getTopLoci: minPurity is orthogonal to the pip cutoff -> drops impure-CS + # variants (v3,v4), keeps pure-CS (v1,v2) and non-CS (v5) + expect_setequal(getTopLoci(e, signalCutoff = 0, minPurity = 0.8)$variant_id, vn[c(1, 2, 5)]) + expect_equal(nrow(getTopLoci(e, signalCutoff = 0)), 5L) # default (NULL) unchanged +}) + diff --git a/tests/testthat/test_GwasSumStats.R b/tests/testthat/test_GwasSumStats.R index 813d733d..a3058353 100644 --- a/tests/testthat/test_GwasSumStats.R +++ b/tests/testthat/test_GwasSumStats.R @@ -245,3 +245,17 @@ test_that("getSumStats() on a multi-study GwasSumStats needs a study selector", expect_error(getSumStats(two, study = "ghost"), "Unknown study") }) +test_that("GwasSumStats: ldSketch is optional (NULL for LD-free workflows)", { + ss <- GwasSumStats(study = "g1", entry = list(.sh_makeQtlSumstatsGr()), + genome = "hg19") # ldSketch omitted -> NULL + expect_null(getLdSketch(ss)) + expect_output(show(ss), "none \\(LD-free\\)") +}) + +test_that("GwasSumStats: a non-GenotypeHandle ldSketch is rejected", { + expect_error( + GwasSumStats(study = "g1", entry = list(.sh_makeQtlSumstatsGr()), + genome = "hg19", ldSketch = "not_a_handle"), + "GenotypeHandle or NULL") +}) + diff --git a/tests/testthat/test_QtlDataset.R b/tests/testthat/test_QtlDataset.R index 04e9b765..48909ed3 100644 --- a/tests/testthat/test_QtlDataset.R +++ b/tests/testthat/test_QtlDataset.R @@ -248,6 +248,61 @@ test_that(".qtlVariantIndices: returns integer(0) when no overlap", { expect_equal(pecotmr:::.qtlVariantIndices(qd, region), integer(0)) }) +# =========================================================================== +# getTraitPosition / .qtlTraitPos +# =========================================================================== + +test_that("getTraitPosition returns each trait's union genomic span across contexts", { + # .qh_makeSe places ENSG1 @ chr1:1000-1500 and ENSG2 @ chr1:2000-2500 in every + # context, so each trait's cross-context union span is that single interval. + qd <- .qh_makeDataset(contexts = c("brain", "liver")) + gr <- getTraitPosition(qd) + expect_s4_class(gr, "GRanges") + expect_setequal(names(gr), c("ENSG1", "ENSG2")) + expect_equal(as.character(GenomicRanges::seqnames(gr["ENSG1"])), "chr1") + expect_equal(GenomicRanges::start(gr["ENSG1"]), 1000L) + expect_equal(GenomicRanges::end(gr["ENSG1"]), 1499L) # start 1000 + width 500 - 1 + expect_equal(GenomicRanges::start(gr["ENSG2"]), 2000L) + # single-trait selection routes through the traitId branch of the method + one <- getTraitPosition(qd, traitId = "ENSG2") + expect_equal(names(one), "ENSG2") + expect_equal(GenomicRanges::start(one), 2000L) +}) + +test_that("getTraitPosition emits a chrUn sentinel for a trait absent from every context", { + qd <- .qh_makeDataset(contexts = "brain") + gr <- getTraitPosition(qd, traitId = "NOPE") + expect_equal(names(gr), "NOPE") + expect_equal(as.character(GenomicRanges::seqnames(gr)), "chrUn") +}) + +# (QtlDataset validity requires a trait's rowRanges to be identical across +# contexts, so the cross-context min/max union in .qtlTraitPos only ever sees +# matching ranges; the two-context fixture above already exercises that loop.) + +# =========================================================================== +# .qtlApplyFilterOverrides +# =========================================================================== + +test_that(".qtlApplyFilterOverrides replaces every supplied slot on a validated copy", { + qd <- .qh_makeDataset(contexts = "brain") + out <- pecotmr:::.qtlApplyFilterOverrides( + qd, mafCutoff = 0.05, macCutoff = 10, xvarCutoff = 0.01, imissCutoff = 0.1, + keepIndel = FALSE, keepSamples = c("s1", "s2"), keepVariants = c("rs1", "rs2")) + expect_equal(out@mafCutoff, 0.05) + expect_equal(out@macCutoff, 10) + expect_equal(out@xvarCutoff, 0.01) + expect_equal(out@imissCutoff, 0.1) + expect_false(out@keepIndel) + expect_equal(out@keepSamples, c("s1", "s2")) + expect_equal(out@keepVariants, c("rs1", "rs2")) +}) + +test_that(".qtlApplyFilterOverrides leaves stored slots untouched when args are NULL", { + qd <- .qh_makeDataset(contexts = "brain") + expect_identical(pecotmr:::.qtlApplyFilterOverrides(qd), qd) +}) + # =========================================================================== # .qtlResolvePhenoSelection # =========================================================================== diff --git a/tests/testthat/test_credibleSetSummary.R b/tests/testthat/test_credibleSetSummary.R new file mode 100644 index 00000000..a47c2483 --- /dev/null +++ b/tests/testthat/test_credibleSetSummary.R @@ -0,0 +1,110 @@ +context("credibleSetSummary") + +test_that("getCredibleSetSummary returns one row per CS with size/purity/V/logBF/lead", { + vn <- paste0("chr1:", (1:5) * 100, ":A:G") + L <- 2L; P <- 5L + alpha <- matrix(0.1, L, P); alpha[1, 1:2] <- c(0.5, 0.4); alpha[2, 3:4] <- c(0.5, 0.4) + lbf <- matrix(c(3.0, 2.5, 0.1, 0.1, 0.0, + 0.1, 0.1, 2.0, 1.8, 0.0), L, P, byrow = TRUE) + fit <- list(alpha = alpha, mu = matrix(0.3, L, P), mu2 = matrix(1.2, L, P), + pip = c(0.6, 0.5, 0.4, 0.4, 0.02), V = c(0.8, 0.5), + lbf_variable = lbf, + sets = list(purity = data.frame( + min.abs.corr = c(0.9, 0.3), mean.abs.corr = c(0.95, 0.4), + row.names = c("L1", "L2")))) + class(fit) <- "susie" + cst <- list(list(sets = list(cs = list(L1 = c(1L, 2L), L2 = c(3L, 4L)), + purity = data.frame(min.abs.corr = c(0.9, 0.3)))), + list(sets = list(cs = list())), list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.70, 0.50) + tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") + e <- FineMappingEntry(variantIds = vn, susieFit = fit, topLoci = tl) + + s <- getCredibleSetSummary(e) + s <- s[order(s$cs), , drop = FALSE] + expect_equal(nrow(s), 2L) + expect_equal(s$cs, c("susie_1", "susie_2")) + expect_equal(s$effect_id, c("L1", "L2")) + expect_equal(s$n_variants, c(2L, 2L)) + expect_equal(s$purity_min, c(0.9, 0.3)) + expect_equal(s$purity_mean, c(0.95, 0.4)) + expect_equal(s$V, c(0.8, 0.5)) + # cs_log10bf = max member logBF (per-variant max single-effect lbf) + expect_equal(s$cs_log10bf, c(3.0, 2.0)) + # cs_log_bf = true per-effect single-effect logBF = logSumExp(lbf[L, ]) - log(P) + expect_equal(s$cs_log_bf, c(1.9597, 1.2031), tolerance = 1e-3) + # cs_pip = summed member PIP (inclusion mass captured) + expect_equal(s$cs_pip, c(1.1, 0.8), tolerance = 1e-6) + # cs_mean_effect = NA for univariate susie (no conditional_effect column) + expect_true(all(is.na(s$cs_mean_effect))) + # lead = highest-PIP member + expect_equal(s$lead_variant, c("chr1:100:A:G", "chr1:300:A:G")) +}) + +test_that("getCredibleSetSummary is empty when there are no credible sets", { + vn <- c("chr1:100:A:G", "chr1:200:C:T") + fit <- list(alpha = matrix(c(0.2, 0.1), 1, 2), mu = matrix(0.1, 1, 2), + mu2 = matrix(1, 1, 2), pip = c(0.05, 0.04)) + class(fit) <- "susie" + cst <- list(list(sets = list(cs = list())), list(sets = list(cs = list())), + list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.70, 0.50) + tl <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") + e <- FineMappingEntry(variantIds = vn, susieFit = fit, topLoci = tl) + expect_equal(nrow(getCredibleSetSummary(e)), 0L) +}) + +test_that("getCredibleSetSummary is empty when the requested coverage column is absent", { + # topLoci carries only cs_95 / cs_70 / cs_50; asking for coverage 0.99 finds no + # cs_99 column -> the .csSummaryFit guard returns the empty summary. + vn <- c("chr1:100:A:G", "chr1:200:C:T") + tl <- data.frame(variant_id = vn, pip = c(0.7, 0.2), logBF = c(2.5, 0.3), + cs_95 = c("susie_1", "susie_1"), cs_95_purity = c(0.9, 0.9), + stringsAsFactors = FALSE) + e <- FineMappingEntry(variantIds = vn, susieFit = list(x = 1), topLoci = tl) + expect_equal(nrow(getCredibleSetSummary(e, coverage = 0.99)), 0L) +}) + +test_that("getCredibleSetSummary reports NA cs_log_bf when the fit carries no lbf matrix", { + # A trimmed fit drops lbf_variable: the per-effect single-effect logBF degrades + # to NA while the max-member cs_log10bf still comes from the topLoci. + vn <- c("chr1:100:A:G", "chr1:200:C:T") + tl <- data.frame(variant_id = vn, pip = c(0.7, 0.2), logBF = c(2.5, 0.3), + cs_95 = c("susie_1", "susie_1"), cs_95_purity = c(0.88, 0.88), + stringsAsFactors = FALSE) + e <- FineMappingEntry(variantIds = vn, susieFit = list(trimmed = TRUE), topLoci = tl) + s <- getCredibleSetSummary(e) + expect_equal(nrow(s), 1L) + expect_true(is.na(s$cs_log_bf)) + expect_equal(s$cs_log10bf, 2.5) +}) + +test_that("getCredibleSetSummary reports NA cs_log_bf when the effect's lbf row is all non-finite", { + # effect 1's lbf row is entirely -Inf, so the finite subset is empty and the + # logSumExp path short-circuits to NA. + vn <- c("chr1:100:A:G", "chr1:200:C:T") + lbf <- matrix(c(-Inf, -Inf, 2.0, 0.1), nrow = 2, byrow = TRUE) + tl <- data.frame(variant_id = vn, pip = c(0.7, 0.2), logBF = c(1.0, 0.3), + cs_95 = c("susie_1", "susie_1"), cs_95_purity = c(0.9, 0.9), + stringsAsFactors = FALSE) + fit <- structure(list(lbf_variable = lbf), class = "susie") + e <- FineMappingEntry(variantIds = vn, susieFit = fit, topLoci = tl) + expect_true(is.na(getCredibleSetSummary(e)$cs_log_bf)) +}) + +test_that("getCredibleSetSummary aggregates across a collection with entry identity", { + mkEntry <- function() { + vn <- c("chr1:100:A:G", "chr1:200:C:T") + tl <- data.frame(variant_id = vn, pip = c(0.7, 0.2), logBF = c(2.5, 0.3), + cs_95 = c("susie_1", "susie_1"), cs_95_purity = c(0.9, 0.9), + stringsAsFactors = FALSE) + FineMappingEntry(variantIds = vn, susieFit = list(x = 1), topLoci = tl) + } + res <- QtlFineMappingResult(study = c("s", "s"), context = c("brain", "blood"), + trait = c("g", "g"), method = c("susie", "susie"), + entry = list(mkEntry(), mkEntry())) + s <- getCredibleSetSummary(res) + expect_true(all(c("study", "context", "trait", "method", "cs") %in% names(s))) + expect_equal(nrow(s), 2L) # one CS per entry + expect_setequal(unique(s$context), c("brain", "blood")) +}) diff --git a/tests/testthat/test_ctwasPipeline.R b/tests/testthat/test_ctwasPipeline.R index cf724b13..4d71a90b 100644 --- a/tests/testthat/test_ctwasPipeline.R +++ b/tests/testthat/test_ctwasPipeline.R @@ -1271,7 +1271,7 @@ test_that("estCtwasParam: fallbackToPrefit recovers from accurate-EM NaN diverge get_boundary_genes = function(...) data.frame(id = "t1", n_regions = 2L), compute_gene_z = function(...) data.frame(id = "t1", z = 1.0), est_param = function(...) stop("Estimated group_prior_var contains NAs!"), - # ctwas:::fit_EM is internal — mock via the same `ctwas` namespace. + # fit_EM is internal to ctwas — mock via the same `ctwas` namespace. fit_EM = function(region_data, ...) list( group_prior = c(g = 0.05, SNP = 1e-4), group_prior_var = c(g = 4.0, SNP = 5.0), diff --git a/tests/testthat/test_fineMappingPipeline.R b/tests/testthat/test_fineMappingPipeline.R index a67275c4..4e864f64 100644 --- a/tests/testthat/test_fineMappingPipeline.R +++ b/tests/testthat/test_fineMappingPipeline.R @@ -144,7 +144,7 @@ context("fineMappingPipeline") .fmp_mockPostprocess <- function() { function(fit, method, dataX, dataY, coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, - region = NULL, conditionIdx = NULL) { + region = NULL, conditionIdx = NULL, ...) { # Capture the requesting method on the FineMappingEntry so the test can # verify the right dispatch happened. if (is.matrix(dataX)) { @@ -503,6 +503,41 @@ test_that("fineMappingPipeline(QtlDataset): runs univariate dispatch with mocked expect_setequal(getMethodNames(res), "susie") }) +test_that("fineMappingPipeline(QtlDataset): threads real trait positions into traitPos provenance", { + qd <- .fmp_makeQtlDataset(contexts = "brain", traits = c("ENSG_A", "ENSG_B")) + local_mocked_bindings( + extractBlockGenotypes = .fmp_mockExtractor(), + .fmFitSusieIndiv = .fmp_mockFitIndiv(), + .fmPostprocessOne = .fmp_mockPostprocess(), + .package = "pecotmr") + res <- suppressMessages( + fineMappingPipeline(qd, methods = "susie", + cisWindow = 1000L, + addSusieInf = FALSE)) + tp <- getTraitPosition(res) + expect_s4_class(tp, "GRanges") + expect_length(tp, nrow(res)) + expect_true(all(as.character(GenomicRanges::seqnames(tp)) == "chr1")) + # TSS (start) is the trait's own rowRanges start from the QtlDataset + # (.fmp_makeSe: ENSG_A -> 1000, ENSG_B -> 2000, width 500), NOT the + # cisWindow-expanded fit region. Map by the row's trait column. + tss <- setNames(GenomicRanges::start(tp), res$trait) + ent <- setNames(GenomicRanges::end(tp), res$trait) + expect_equal(tss[["ENSG_A"]], 1000L) + expect_equal(tss[["ENSG_B"]], 2000L) + expect_equal(ent[["ENSG_A"]], 1499L) + expect_equal(ent[["ENSG_B"]], 2499L) + # region is the SAME trait span expanded by cisWindow (1000), start clamped at + # 1 -- distinct from the bare traitPos above. + reg <- getRegion(res) + rs <- setNames(GenomicRanges::start(reg), res$trait) + re <- setNames(GenomicRanges::end(reg), res$trait) + expect_equal(rs[["ENSG_A"]], 1L) # 1000 - 1000 -> clamp + expect_equal(re[["ENSG_A"]], 2499L) # 1499 + 1000 + expect_equal(rs[["ENSG_B"]], 1000L) # 2000 - 1000 + expect_equal(re[["ENSG_B"]], 3499L) # 2499 + 1000 +}) + test_that(".fmAfForX: returns directional effect-allele af aligned to colnames(X)", { qd <- .fmp_makeQtlDataset(contexts = "brain", traits = "ENSG_A") local_mocked_bindings( @@ -541,7 +576,7 @@ test_that("fineMappingPipeline(QtlDataset): threads directional af into postproc recordingPostprocess <- function(fit, method, dataX, dataY, coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, region = NULL, - conditionIdx = NULL) { + conditionIdx = NULL, ...) { captured$af <- af captured$cols <- colnames(dataX) vids <- colnames(dataX) @@ -1003,6 +1038,18 @@ test_that("fineMappingPipeline(QtlDataset): mvsusie multi-trait single-context d expect_equal(nrow(res), 2L) expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) expect_setequal(getMethodNames(res), "mvsusie") + # Engine-built (multivariate) FM rows carry BOTH provenance columns, derived in + # the shared .runJointCell seam: traitPos = the bare trait position, region = + # traitPos +/- cisWindow (1000). This is the path the univariate pushRow + # threading never touches, so it is the regression guard for the engine fix. + tp <- getTraitPosition(res); reg <- getRegion(res) + expect_s4_class(tp, "GRanges"); expect_s4_class(reg, "GRanges") + tpS <- setNames(GenomicRanges::start(tp), res$trait) + regS <- setNames(GenomicRanges::start(reg), res$trait) + regE <- setNames(GenomicRanges::end(reg), res$trait) + expect_equal(tpS[["ENSG_A"]], 1000L); expect_equal(tpS[["ENSG_B"]], 2000L) + expect_equal(regS[["ENSG_A"]], 1L); expect_equal(regE[["ENSG_A"]], 2499L) + expect_equal(regS[["ENSG_B"]], 1000L); expect_equal(regE[["ENSG_B"]], 3499L) }) test_that("fineMappingPipeline(QtlDataset): mvsusie multi-context single-trait dispatch", { diff --git a/tests/testthat/test_fineMappingWrappers.R b/tests/testthat/test_fineMappingWrappers.R index 99343d5c..6431fec6 100644 --- a/tests/testthat/test_fineMappingWrappers.R +++ b/tests/testthat/test_fineMappingWrappers.R @@ -511,8 +511,12 @@ if (!exists(".make_univariate_data", inherits = FALSE)) { "variant_id", "chrom", "pos", "A1", "A2", "N", "af", "marginal_beta", "marginal_se", "marginal_z", "marginal_p", - "pip", "posterior_mean", "posterior_sd", - "cs_95", "cs_70", "cs_50", "cs_95_purity", + "pip", "posterior_mean", "posterior_sd", "logBF", + # CS columns are derived from the coverages the pipeline produced; for the + # default coverages (0.95/0.70/0.50) memberships lead, then purities. + "cs_95", "cs_70", "cs_50", "cs_95_purity", "cs_70_purity", "cs_50_purity", + # per-CS variant-level default column (alpha in the assigned CS's effect) + "within_cs_pip", "method", "gene", "event", "grange_start", "grange_end" ) @@ -657,6 +661,103 @@ test_that("buildTopLoci: conditionIdx slices the 3-D mvsusie posterior per condi expect_true(all(is.na(tl0$posterior_mean))) }) +test_that("buildTopLoci stamps per-condition lfsr + conditional_effect for mvsusie (long + numeric)", { + L <- 2L; p <- 4L; R <- 2L + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A", "chr1:400:T:C") + alpha <- matrix(0.1, L, p); alpha[1, 1:2] <- c(0.6, 0.3) + mu <- array(0.3, c(L, p, R)); mu2 <- array(1.2, c(L, p, R)) + pip <- c(0.6, 0.4, 0.05, 0.04) + coef <- matrix(c(0.5, 0.4, 0.1, 0.05, 0.2, 0.1, 0.02, 0.01), p, R, + dimnames = list(vids, c("c1", "c2"))) + # conditional_lfsr is the raw-fit field name (trimmed fits rename it `clfsr`). + clfsr <- array(0.5, c(L, p, R)) + clfsr[1, 1, 1] <- 0.001; clfsr[1, 2, 1] <- 0.02 + clfsr[1, 1, 2] <- 0.30; clfsr[1, 2, 2] <- 0.40 + fit <- list(pip = pip, alpha = alpha, mu = mu, mu2 = mu2, + coef = coef, conditional_lfsr = clfsr, V = rep(1, L)) + class(fit) <- c("mvsusie", "susie") + cst <- list(list(sets = list(cs = list(L1 = c(1L, 2L)), + purity = data.frame(min.abs.corr = 0.9))), + list(sets = list(cs = list())), + list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.70, 0.50) + + tl1 <- buildTopLoci(fit, cst, variantNames = vids, method = "mvsusie", conditionIdx = 1L) + expect_true(all(c("conditional_effect", "lfsr") %in% names(tl1))) + expect_true(is.numeric(tl1$conditional_effect) && is.numeric(tl1$lfsr)) + # conditional_effect = coef[, condition] / pip, for every variant + expect_equal(unname(tl1$conditional_effect), unname(coef[, 1] / pip)) + # lfsr populated ONLY for the 0.95 CS variants, pulled from clfsr[L, variant, condition] + expect_equal(tl1$lfsr[1:2], c(0.001, 0.02)) + expect_true(all(is.na(tl1$lfsr[3:4]))) + # conditionIdx = 2 selects the other condition's coef + clfsr slice + tl2 <- buildTopLoci(fit, cst, variantNames = vids, method = "mvsusie", conditionIdx = 2L) + expect_equal(unname(tl2$conditional_effect), unname(coef[, 2] / pip)) + expect_equal(tl2$lfsr[1:2], c(0.30, 0.40)) + # univariate fit (no conditionIdx) keeps the base schema, no extra columns + tl0 <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") + expect_false(any(c("conditional_effect", "lfsr") %in% names(tl0))) +}) + +test_that("getTopLoci surfaces mvsusie conditional_effect + lfsr through the projector", { + tl <- data.frame( + variant_id = c("chr1:100:A:G", "chr1:200:C:T"), + chrom = "1", pos = c(100L, 200L), A1 = c("A", "C"), A2 = c("G", "T"), + pip = c(0.6, 0.4), posterior_mean = c(0.1, 0.2), posterior_sd = c(0.05, 0.05), + cs_95 = c("mvsusie_1", "mvsusie_1"), + conditional_effect = c(0.3, -0.2), lfsr = c(0.001, 0.02), + stringsAsFactors = FALSE) + e <- FineMappingEntry(variantIds = tl$variant_id, + susieFit = list(pip = tl$pip), topLoci = tl) + out <- getTopLoci(e, signalCutoff = 0) + expect_true(all(c("conditional_effect", "lfsr") %in% names(out))) + expect_equal(out$lfsr, c(0.001, 0.02)) + expect_equal(out$conditional_effect, c(0.3, -0.2)) +}) + +test_that("buildTopLoci derives CS columns from the ACTUAL coverages (no hardcoded 0.95/0.70/0.50)", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + fit <- list(alpha = matrix(c(0.7, 0.2, 0.1), 1, 3), + mu = matrix(0.3, 1, 3), mu2 = matrix(1.2, 1, 3), + pip = c(0.7, 0.2, 0.1)) + class(fit) <- "susie" + mkCt <- function(cs, pu) list(sets = list(cs = cs, purity = data.frame(min.abs.corr = pu))) + # Non-default coverages must NOT be silently dropped or mislabeled as 0.95/0.70/0.50. + cst <- list(mkCt(list(L1 = c(1L, 2L)), 0.85), mkCt(list(), numeric())) + attr(cst, "coverage") <- c(0.9, 0.8) + tl <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") + expect_true(all(c("cs_90", "cs_80", "cs_90_purity", "cs_80_purity") %in% names(tl))) + expect_false(any(c("cs_95", "cs_70", "cs_50") %in% names(tl))) + expect_equal(tl$cs_90, c("susie_1", "susie_1", "susie_0")) + expect_equal(tl$cs_90_purity, c(0.85, 0.85, 0)) + # Default coverages still yield cs_95/70/50 plus a purity column per coverage. + cst2 <- list(mkCt(list(L1 = c(1L, 2L)), 0.9), + mkCt(list(), numeric()), mkCt(list(), numeric())) + attr(cst2, "coverage") <- c(0.95, 0.70, 0.50) + tl2 <- buildTopLoci(fit, cst2, variantNames = vids, method = "susie") + expect_true(all(c("cs_95", "cs_70", "cs_50", + "cs_95_purity", "cs_70_purity", "cs_50_purity") %in% names(tl2))) +}) + +test_that("buildTopLoci stamps per-variant logBF (max single-effect lbf; replaces log10_base_factor)", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + lbf <- matrix(c(2.0, 0.1, -1.0, + 0.5, 3.0, 0.2), nrow = 2, byrow = TRUE) # L=2 effects x p=3 + fit <- list(alpha = matrix(c(0.7, 0.2, 0.1, 0.3, 0.4, 0.3), 2, 3), + mu = matrix(0.3, 2, 3), mu2 = matrix(1.2, 2, 3), + pip = c(0.7, 0.5, 0.3), lbf_variable = lbf) + class(fit) <- "susie" + cst <- list(list(sets = list(cs = list())), list(sets = list(cs = list())), + list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.70, 0.50) + tl <- buildTopLoci(fit, cst, variantNames = vids, method = "susie") + expect_true("logBF" %in% names(tl)) + expect_equal(tl$logBF, apply(lbf, 2, max)) # c(2.0, 3.0, 0.2) + # surfaced through getTopLoci's projection too + e <- FineMappingEntry(variantIds = vids, susieFit = fit, topLoci = tl) + expect_true("logBF" %in% names(getTopLoci(e, signalCutoff = 0))) +}) + test_that("buildTopLoci emits 22 columns in the fixed order on a non-empty fit", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") inp <- .fake_fit_and_cs(variant_ids, @@ -680,6 +781,81 @@ test_that("buildTopLoci emits 22 columns in the fixed order on a non-empty fit", expect_equal(unique(out$method), "susie") }) +test_that("buildTopLoci fullFit: within_cs_pip default + wide per-CS matrices", { + vn <- paste0("chr1:", (1:5) * 100, ":A:G"); L <- 2L; P <- 5L + alpha <- matrix(0.1, L, P); alpha[1, 1:2] <- c(0.5, 0.4); alpha[2, 3:4] <- c(0.5, 0.4) + lbf <- matrix(c(3, 2.5, 0.1, 0.1, 0, 0.1, 0.1, 2, 1.8, 0), L, P, byrow = TRUE) + # NON-UNIT, per-variant scale factors so the mu/scale (and mu2/scale^2) + # UNSCALING is actually exercised — rep(1, P) would let a multiply-vs-divide + # or per-variant misalignment bug pass silently. + scale <- c(2, 4, 0.5, 1, 5) + fit <- list(alpha = alpha, mu = matrix(0.3, L, P), mu2 = matrix(1.2, L, P), + pip = c(0.6, 0.5, 0.4, 0.4, 0.02), V = c(0.8, 0.5), lbf_variable = lbf, + X_column_scale_factors = scale, + sets = list(purity = data.frame(min.abs.corr = c(0.9, 0.3), + mean.abs.corr = c(0.95, 0.4), row.names = c("L1", "L2")))) + class(fit) <- "susie" + cst <- list(list(sets = list(cs = list(L1 = c(1L, 2L), L2 = c(3L, 4L)), + purity = data.frame(min.abs.corr = c(0.9, 0.3)))), + list(sets = list(cs = list())), list(sets = list(cs = list()))) + attr(cst, "coverage") <- c(0.95, 0.7, 0.5) + + # Default: within_cs_pip = alpha in the assigned CS's effect (NA for non-CS row 5). + tl0 <- buildTopLoci(fit, cst, variantNames = vn, method = "susie") + expect_true("within_cs_pip" %in% names(tl0)) + expect_false(any(grepl("_cs[0-9]", names(tl0)))) + expect_equal(tl0$within_cs_pip, c(0.5, 0.4, 0.5, 0.4, NA_real_)) + + # fullFit + all matrices: wide per-CS alpha / lbf / effect / effect-variance. + tl1 <- buildTopLoci(fit, cst, variantNames = vn, method = "susie", + fullFit = TRUE, fullFitAlphaOnly = FALSE) + expect_equal(tl1$within_cs_pip_cs1, alpha[1, ]) + expect_equal(tl1$cs_logbf_cs1, lbf[1, ]) + expect_equal(tl1$cs_effect_cs1, 0.3 / scale) # mu / scale + expect_equal(tl1$cs_effect_var_cs1, (1.2 - 0.09) / scale^2) # (mu2 - mu^2) / scale^2 + + # fullFitAlphaOnly (default TRUE): only alpha widened, both passing CS. + tl2 <- buildTopLoci(fit, cst, variantNames = vn, method = "susie", fullFit = TRUE) + expect_false(any(grepl("^cs_logbf_|^cs_effect_", names(tl2)))) + expect_setequal(grep("^within_cs_pip_", names(tl2), value = TRUE), + c("within_cs_pip_cs1", "within_cs_pip_cs2")) +}) + +test_that("buildTopLoci fullFit on the committed qtl_finemapping_example (real CS)", { + # A genuine chr22 SuSiE fit shipped as a package dataset: region_1/context_1 + # carries a real 42-variant credible set. Exercises within_cs_pip + the + # alpha-wide column on REAL data (the synthetic case above pins the exact + # arithmetic; this pins that it flows on a real fit). The dataset fit is + # trimmed to alpha/pip/V/sets, so requesting the full matrices must degrade + # gracefully rather than error. + e <- new.env() + data("qtl_finemapping_example", package = "pecotmr", envir = e) + fit <- e$qtl_finemapping_example$region_1$context_1$susie_result_trimmed + vn <- colnames(fit$alpha) + member <- fit$sets$cs$L1 # 42 real CS member indices + expect_gt(length(member), 1L) + + csTables <- list(list(sets = fit$sets, cs_corr = fit$cs_corr, pip = fit$pip)) + names(csTables) <- formatCsColumn(0.95, method = "susie") + attr(csTables, "coverage") <- 0.95 + + tl <- as.data.frame(buildTopLoci(fit, csTables, variantNames = vn, + method = "susie", signalCutoff = 0, fullFit = TRUE, fullFitAlphaOnly = TRUE)) + # within_cs_pip is populated for exactly the CS members, = their L1 alpha. + expect_equal(sum(!is.na(tl$within_cs_pip)), length(member)) + expect_equal(tl$within_cs_pip[match(vn[member], tl$variant_id)], + as.numeric(fit$alpha[1, member])) + # alpha-wide column carries the full effect-1 posterior inclusion vector. + expect_equal(tl$within_cs_pip_cs1, as.numeric(fit$alpha[1, ])) + + # Trimmed fit (no mu / mu2 / lbf_variable): full-matrix request is a no-op for + # the effect columns, not an error. + tlF <- as.data.frame(buildTopLoci(fit, csTables, variantNames = vn, + method = "susie", signalCutoff = 0, fullFit = TRUE, fullFitAlphaOnly = FALSE)) + expect_false(any(grepl("^cs_logbf_|^cs_effect_", names(tlF)))) + expect_true("within_cs_pip_cs1" %in% names(tlF)) +}) + test_that("buildTopLoci exports af (not MAF) and carries the supplied af values", { variant_ids <- c("chr1:100:A:G", "chr1:200:C:T") inp <- .fake_fit_and_cs( @@ -1803,6 +1979,20 @@ test_that("fsusieWeights returns a variants x features matrix with variant rowna expect_equal(rownames(W), colnames(obj$X)) }) +test_that("computeCsTable (fsusie) stamps WITHIN-CS purity via cal_purity, not cal_cor_cs (regression)", { + skip_if_not_installed("fsusieR"); skip_if_not_installed("wavethresh") + obj <- .fw_makeFsusieFit() + ct <- computeCsTable(obj$fit, obj$X, coverage = 0.95, csInput = "fsusie") + # purity is stamped as min.abs.corr (the susieR-path shape .csPurityVec reads) + expect_true(!is.null(ct$sets$purity) && "min.abs.corr" %in% names(ct$sets$purity)) + calP <- as.numeric(unlist(fsusieR::cal_purity(ct$sets$cs, obj$X))) + pv <- .csPurityVec(ct) + # exactly one purity per CS (bug: previously iterated the fit's ~36 slots), and + # equal to fsusieR's own cal_purity (min |corr| within each CS) + expect_equal(length(pv), length(ct$sets$cs)) + expect_equal(pv, calP, tolerance = 1e-6) +}) + test_that("fsusieWeights matches fsusieR's own out_prep reconstruction (post_processing='none')", { skip_if_not_installed("fsusieR") skip_if_not_installed("wavethresh") diff --git a/tests/testthat/test_fsusieAccessors.R b/tests/testthat/test_fsusieAccessors.R new file mode 100644 index 00000000..2c85eb87 --- /dev/null +++ b/tests/testthat/test_fsusieAccessors.R @@ -0,0 +1,158 @@ +context("fsusieAccessors") + +.fsa_makeFit <- function() { + set.seed(1); n <- 150L; p <- 24L; J <- 16L + X <- matrix(rnorm(n * p), n, p, + dimnames = list(paste0("s", seq_len(n)), + paste0("chr1:", (seq_len(p)) * 100, ":A:G"))) + b1 <- sin(seq(0, 2 * pi, length.out = J)) + b2 <- cos(seq(0, pi, length.out = J)) + Y <- X[, 3] %o% b1 + X[, 10] %o% b2 + matrix(rnorm(n * J, sd = 0.3), n, J) + colnames(Y) <- paste0("f", seq_len(J)) + suppressWarnings(fsusieR::susiF(X = X, Y = Y, pos = seq_len(J), L = 5, + post_processing = "none", verbose = FALSE)) +} +.fsa_entry <- function(fit, purityVal = 0.85) { + vids <- names(fit$csd_X) + pipv <- if (!is.null(fit$pip)) as.numeric(fit$pip) else rep(0.1, length(vids)) + # Canonical CS labels + purity from the fit's CS membership, mirroring what + # fsusieWrapper stamps into a real FMR's topLoci (cs_95 / cs_95_purity). + cs95 <- rep("fsusie_0", length(vids)) + for (l in seq_along(fit$cs)) { + idx <- fit$cs[[l]]; if (is.numeric(idx)) idx <- as.integer(idx) + cs95[idx] <- paste0("fsusie_", l) + } + tl <- data.frame(variant_id = vids, pip = pipv, cs_95 = cs95, + cs_95_purity = ifelse(cs95 != "fsusie_0", purityVal, 0), + stringsAsFactors = FALSE) + FineMappingEntry(variantIds = vids, susieFit = fit, topLoci = tl) +} + +test_that("fsusieCredibleBand returns a long effect + band table (lower <= effect <= upper)", { + skip_if_not_installed("fsusieR"); skip_if_not_installed("wavethresh") + cb <- fsusieCredibleBand(.fsa_entry(.fsa_makeFit())) + expect_named(cb, c("cs", "chrom", "pos", "effect", "lower", "upper")) + expect_gt(nrow(cb), 0) + expect_true(all(cb$lower <= cb$effect + 1e-9 & cb$effect <= cb$upper + 1e-9)) + expect_true(all(grepl("^fsusie_", cb$cs))) +}) + +test_that("fsusieAffectedRegions returns a GRanges with cs / purity / direction", { + skip_if_not_installed("fsusieR"); skip_if_not_installed("wavethresh") + gr <- fsusieAffectedRegions(.fsa_entry(.fsa_makeFit(), purityVal = 0.85)) + expect_s4_class(gr, "GRanges") + expect_gt(length(gr), 0) + expect_true(all(c("cs", "purity", "direction") %in% names(S4Vectors::mcols(gr)))) + expect_true(all(S4Vectors::mcols(gr)$direction %in% c("pos", "neg", NA))) + # purity sourced from the entry's cs_95_purity (matched by CS variant membership), + # NOT the (nonexistent) fit$purity slot + expect_true(all(S4Vectors::mcols(gr)$purity == 0.85)) + expect_true(all(grepl("^fsusie_", S4Vectors::mcols(gr)$cs))) +}) + +test_that("fsusie accessors degrade to empty for a non-fSuSiE / trimmed fit (no wavelet slots)", { + e <- FineMappingEntry(variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), + topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5, + stringsAsFactors = FALSE)) + expect_equal(nrow(fsusieCredibleBand(e)), 0L) + expect_equal(length(fsusieAffectedRegions(e)), 0L) +}) + +test_that("fsusieCredibleBand + fsusieAffectedRegions aggregate across a collection", { + skip_if_not_installed("fsusieR"); skip_if_not_installed("wavethresh") + fit <- .fsa_makeFit() # deterministic; reuse for both rows + res <- QtlFineMappingResult( + study = c("s", "s"), context = c("brain", "blood"), + trait = c("g", "g"), method = c("fsusie", "fsusie"), + entry = list(.fsa_entry(fit), .fsa_entry(fit))) + + cb <- fsusieCredibleBand(res) + expect_true(all(c("study", "context", "trait", "method", + "cs", "effect", "lower", "upper") %in% names(cb))) + expect_gt(nrow(cb), 0) + expect_setequal(unique(cb$context), c("brain", "blood")) + + gr <- fsusieAffectedRegions(res) + expect_s4_class(gr, "GRanges") + expect_gt(length(gr), 0) + expect_true(all(c("study", "context", "trait", "cs", "purity", "direction") + %in% names(S4Vectors::mcols(gr)))) + expect_setequal(unique(S4Vectors::mcols(gr)$context), c("brain", "blood")) +}) + +test_that("fsusieAffectedRegions on a collection of non-fSuSiE entries is an empty GRanges", { + e <- FineMappingEntry(variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), + topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5, + stringsAsFactors = FALSE)) + res <- QtlFineMappingResult(study = "s", context = "c", trait = "t", + method = "susie", entry = list(e)) + expect_equal(length(fsusieAffectedRegions(res)), 0L) +}) + +test_that(".fsusieChrom returns NA when the fit has no named variants", { + expect_true(is.na(pecotmr:::.fsusieChrom(list(csd_X = c(1, 2, 3))))) # unnamed + expect_true(is.na(pecotmr:::.fsusieChrom(list()))) # no csd_X +}) + +test_that(".fsusieCsMapFromTopLoci falls back to index labels when topLoci lacks CS columns", { + fit <- list(cs = list(1L, 2L), + csd_X = stats::setNames(1:3, paste0("chr1:", 1:3 * 100, ":A:G"))) + m <- pecotmr:::.fsusieCsMapFromTopLoci(fit, topLoci = NULL) + expect_equal(unname(m$label), c("fsusie_1", "fsusie_2")) + expect_true(all(is.na(m$purity))) + # a topLoci missing the required cs_95 / cs_95_purity columns takes the same path + m2 <- pecotmr:::.fsusieCsMapFromTopLoci(fit, topLoci = data.frame(variant_id = "x")) + expect_equal(unname(m2$label), c("fsusie_1", "fsusie_2")) +}) + +# A minimal object that passes .isFsusieFit (the wavelet-slot gate) so the band / +# affected-region degradation paths can be exercised with the (untrimmed) band +# computation replaced by a mock returning a controlled, degenerate fit. +.fsa_fakeFit <- function() + list(fitted_wc2 = 1, fitted_func = list(1), outing_grid = 1:2, alpha = 1) +.fsa_bareEntry <- function() + FineMappingEntry(variantIds = "chr1:100:A:G", susieFit = .fsa_fakeFit(), + topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5, + stringsAsFactors = FALSE)) + +test_that("fsusieCredibleBand skips NULL effect bands and degrades to empty", { + skip_if_not_installed("fsusieR") + testthat::local_mocked_bindings( + .fsusiePopulateCredibleBand = function(fit) list( + outing_grid = c(100, 200), + csd_X = stats::setNames(1:2, c("chr1:100:A:G", "chr1:200:A:G")), + cred_band = list(NULL, NULL), fitted_func = list(NULL, NULL)), + .package = "pecotmr") + expect_equal(nrow(fsusieCredibleBand(.fsa_bareEntry())), 0L) +}) + +test_that("fsusieAffectedRegions degrades to empty when affected_reg finds nothing", { + skip_if_not_installed("fsusieR") + testthat::local_mocked_bindings( + .fsusiePopulateCredibleBand = function(fit) list( + outing_grid = c(100, 200), + csd_X = stats::setNames(1:2, c("chr1:100:A:G", "chr1:200:A:G")), + fitted_func = list(c(1, 1))), + .package = "pecotmr") + testthat::local_mocked_bindings(affected_reg = function(...) NULL, .package = "fsusieR") + expect_equal(length(fsusieAffectedRegions(.fsa_bareEntry())), 0L) +}) + +test_that("fsusieAffectedRegions yields NA direction for a region outside the grid", { + skip_if_not_installed("fsusieR") + testthat::local_mocked_bindings( + .fsusiePopulateCredibleBand = function(fit) list( + outing_grid = c(100, 200), + csd_X = stats::setNames(1:2, c("chr1:100:A:G", "chr1:200:A:G")), + fitted_func = list(c(1, 1))), + .package = "pecotmr") + # Region [500, 600] lies outside the grid [100, 200]: no grid points fall in it, + # so the per-region effect-direction summary is NA. + testthat::local_mocked_bindings( + affected_reg = function(...) data.frame(CS = 1L, Start = 500, End = 600), + .package = "fsusieR") + gr <- fsusieAffectedRegions(.fsa_bareEntry()) + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 1L) + expect_true(is.na(S4Vectors::mcols(gr)$direction)) +}) diff --git a/tests/testthat/test_getLbf.R b/tests/testthat/test_getLbf.R new file mode 100644 index 00000000..5544ed59 --- /dev/null +++ b/tests/testthat/test_getLbf.R @@ -0,0 +1,50 @@ +context("getLbf") + +test_that("getLbf returns the wide variant x effect lbf matrix", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + lbf <- matrix(c(3.0, 2.5, 0.1, + 0.1, 0.1, 2.0), nrow = 2, byrow = TRUE) # L=2 x p=3 + fit <- list(alpha = matrix(0.2, 2, 3), mu = matrix(0.1, 2, 3), + mu2 = matrix(1, 2, 3), pip = c(0.5, 0.4, 0.3), lbf_variable = lbf) + class(fit) <- "susie" + e <- FineMappingEntry(variantIds = vids, susieFit = fit, + topLoci = data.frame(variant_id = vids, pip = fit$pip, + stringsAsFactors = FALSE)) + w <- getLbf(e) + expect_equal(w$variant_id, vids) + expect_true(all(c("lbf_L1", "lbf_L2") %in% names(w))) + expect_equal(w$lbf_L1, lbf[1, ]) # effect 1's lbf across variants + expect_equal(w$lbf_L2, lbf[2, ]) # effect 2's lbf across variants +}) + +test_that("getLbf is empty when the fit carries no lbf matrix", { + e <- FineMappingEntry(variantIds = "chr1:100:A:G", susieFit = list(pip = 0.5), + topLoci = data.frame(variant_id = "chr1:100:A:G", pip = 0.5, + stringsAsFactors = FALSE)) + expect_equal(nrow(getLbf(e)), 0L) +}) + +test_that("getLbf aggregates over a collection, carrying identity + NA-filling ragged effects", { + vids <- c("chr1:100:A:G", "chr1:200:C:T", "chr1:300:G:A") + mkEntry <- function(L) { + lbf <- matrix(seq_len(L * length(vids)), nrow = L, byrow = TRUE) # L x p + fit <- structure(list(lbf_variable = lbf, pip = rep(0.3, length(vids))), + class = "susie") + FineMappingEntry(variantIds = vids, susieFit = fit, + topLoci = data.frame(variant_id = vids, pip = rep(0.3, length(vids)), + stringsAsFactors = FALSE)) + } + # Two entries with different effect counts (L = 2 vs 3) exercise the NA-fill of + # the ragged lbf_L columns described in the collection method's contract. + res <- QtlFineMappingResult( + study = c("s1", "s1"), context = c("brain", "blood"), + trait = c("g", "g"), method = c("susie", "susie"), + entry = list(mkEntry(2L), mkEntry(3L))) + w <- getLbf(res) + expect_true(all(c("study", "context", "trait", "method", "variant_id") %in% names(w))) + expect_equal(nrow(w), 6L) # 2 entries x 3 variants + expect_setequal(unique(w$context), c("brain", "blood")) + expect_true("lbf_L3" %in% names(w)) + expect_true(all(is.na(w$lbf_L3[w$context == "brain"]))) # L = 2 entry: no effect 3 + expect_true(all(!is.na(w$lbf_L3[w$context == "blood"]))) # L = 3 entry: present +}) diff --git a/tests/testthat/test_h2Annotations.R b/tests/testthat/test_h2Annotations.R index c987e44c..fdf5952a 100644 --- a/tests/testthat/test_h2Annotations.R +++ b/tests/testthat/test_h2Annotations.R @@ -2,125 +2,6 @@ # === Tests migrated from test_h2ClassesSumstats.R (h2Annotations) === -test_that("AnnotationMatrix validates dimensions and meta", { - gr <- make_test_granges(10) - meta <- make_test_annotation_meta() - mat <- matrix(0, nrow = 10, ncol = 3) - - obj <- AnnotationMatrix(mat, gr, meta) - expect_s4_class(obj, "AnnotationMatrix") - expect_true(methods::validObject(obj)) -}) - - -test_that("AnnotationMatrix rejects row mismatch", { - gr <- make_test_granges(10) - meta <- make_test_annotation_meta() - mat <- matrix(0, nrow = 5, ncol = 3) # wrong number of rows - - expect_error( - AnnotationMatrix(mat, gr, meta), - "rows.*must match" - ) -}) - - -test_that("AnnotationMatrix rejects column mismatch with meta", { - gr <- make_test_granges(10) - meta <- make_test_annotation_meta() # 3 annotations - mat <- matrix(0, nrow = 10, ncol = 2) # only 2 columns - - # Constructor errors when colnames assignment fails (dimnames mismatch) - expect_error(AnnotationMatrix(mat, gr, meta)) -}) - - -test_that("AnnotationMatrix rejects invalid tier values", { - gr <- make_test_granges(10) - meta <- data.frame( - name = "x", tier = "invalid_tier", type = "binary", - stringsAsFactors = FALSE - ) - mat <- matrix(0, nrow = 10, ncol = 1) - - expect_error( - AnnotationMatrix(mat, gr, meta), - "tier.*baseline.*candidate" - ) -}) - - -test_that("AnnotationMatrix rejects invalid type values", { - gr <- make_test_granges(10) - meta <- data.frame( - name = "x", tier = "baseline", type = "ordinal", - stringsAsFactors = FALSE - ) - mat <- matrix(0, nrow = 10, ncol = 1) - - expect_error( - AnnotationMatrix(mat, gr, meta), - "type.*binary.*continuous" - ) -}) - - -test_that("AnnotationMatrix() constructor creates object from matrix", { - n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() - mat <- matrix(runif(n * 3), nrow = n, ncol = 3) - - obj <- AnnotationMatrix(mat, gr, meta, genome = "hg38") - expect_s4_class(obj, "AnnotationMatrix") - expect_equal(nrow(obj@annotations), n) - expect_equal(ncol(obj@annotations), 3) - expect_equal(obj@genome, "hg38") -}) - - -test_that("AnnotationMatrix() sets column names from annotation_meta", { - n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() - mat <- matrix(0, nrow = n, ncol = 3) - # No colnames set on mat - - obj <- AnnotationMatrix(mat, gr, meta) - expect_equal(colnames(obj@annotations), c("base", "enhancer", "promoter")) -}) - - -test_that("getbaseline() subsets to baseline-tier only", { - n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() # 1 baseline, 2 candidate - mat <- matrix(0, nrow = n, ncol = 3) - - obj <- AnnotationMatrix(mat, gr, meta) - baseline <- getBaseline(obj) - - expect_s4_class(baseline, "AnnotationMatrix") - expect_equal(ncol(baseline@annotations), 1) - expect_true(all(baseline@annotationMeta$tier == "baseline")) -}) - - -test_that("getcandidates() subsets to candidate-tier only", { - n <- 10 - gr <- make_test_granges(n) - meta <- make_test_annotation_meta() # 1 baseline, 2 candidate - mat <- matrix(0, nrow = n, ncol = 3) - - obj <- AnnotationMatrix(mat, gr, meta) - cand <- getCandidates(obj) - - expect_s4_class(cand, "AnnotationMatrix") - expect_equal(ncol(cand@annotations), 2) - expect_true(all(cand@annotationMeta$tier == "candidate")) -}) - - test_that(".annot_detect_format() detects bigwig, bed, ldsc_annot", { detect <- pecotmr:::.annotDetectFormat @@ -435,26 +316,9 @@ test_that("readannotations with multiple files creates multi-column matrix", { }) # ============================================================================= -# AnnotationMatrix argument guards, BigWig reader, LDSC CHR/BP guard +# BigWig reader, LDSC CHR/BP guard # ============================================================================= -test_that("AnnotationMatrix rejects a non-data.frame annotationMeta", { - gr <- make_test_granges(10) - expect_error( - AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = list(a = 1)), - "annotationMeta must be a data.frame" - ) -}) - -test_that("AnnotationMatrix rejects annotationMeta missing required columns", { - gr <- make_test_granges(10) - bad_meta <- data.frame(foo = c("a", "b", "c"), stringsAsFactors = FALSE) - expect_error( - AnnotationMatrix(matrix(0, 10, 3), gr, annotationMeta = bad_meta), - "must have columns: name, tier, type" - ) -}) - test_that(".readBigwigAtSnps returns the mean BigWig score at each SNP", { skip_if_not_installed("rtracklayer") gr <- GenomicRanges::GRanges( diff --git a/tests/testthat/test_h2EstimationWrappers.R b/tests/testthat/test_h2EstimationWrappers.R index a0c78057..a62b13b3 100644 --- a/tests/testthat/test_h2EstimationWrappers.R +++ b/tests/testthat/test_h2EstimationWrappers.R @@ -730,7 +730,7 @@ test_that("standardize_tau_star returns list with tauStar and tauStarSe", { # ============================================================================= test_that("meta_random_effects returns all NA with k=0", { - res <- pecotmr:::metaRandomEffects(numeric(0), numeric(0)) + res <- pecotmr:::.rmaMeta(numeric(0), numeric(0)) expect_true(is.na(res$mean)) expect_true(is.na(res$se)) expect_true(is.na(res$tau2)) @@ -739,7 +739,7 @@ test_that("meta_random_effects returns all NA with k=0", { }) test_that("meta_random_effects with k=1 returns input values", { - res <- pecotmr:::metaRandomEffects(5.0, 1.0) + res <- pecotmr:::.rmaMeta(5.0, 1.0) expect_equal(res$mean, 5.0) expect_equal(res$se, 1.0) expect_equal(res$tau2, 0) @@ -748,7 +748,7 @@ test_that("meta_random_effects with k=1 returns input values", { test_that("meta_random_effects with identical means gives tau2=0", { means <- rep(3.0, 5) ses <- rep(1.0, 5) - res <- pecotmr:::metaRandomEffects(means, ses) + res <- pecotmr:::.rmaMeta(means, ses) expect_equal(res$tau2, 0) expect_equal(res$mean, 3.0) }) @@ -757,7 +757,7 @@ test_that("meta_random_effects returns correct structure", { set.seed(42) means <- rnorm(5, mean = 2, sd = 0.5) ses <- rep(0.5, 5) - res <- pecotmr:::metaRandomEffects(means, ses) + res <- pecotmr:::.rmaMeta(means, ses) expect_true(is.list(res)) expect_named(res, c("mean", "se", "tau2", "I2", "Q")) expect_true(res$se > 0) @@ -768,11 +768,11 @@ test_that("meta_random_effects returns correct structure", { test_that("meta_random_effects errors with non-positive ses", { expect_error( - pecotmr:::metaRandomEffects(c(1, 2), c(1, 0)), + pecotmr:::.rmaMeta(c(1, 2), c(1, 0)), "all ses must be positive and finite" ) expect_error( - pecotmr:::metaRandomEffects(c(1, 2), c(1, -1)), + pecotmr:::.rmaMeta(c(1, 2), c(1, -1)), "all ses must be positive and finite" ) }) @@ -781,7 +781,7 @@ test_that("meta_random_effects known DerSimonian-Laird example", { # Three studies with known values means <- c(0.5, 0.8, 0.3) ses <- c(0.2, 0.3, 0.15) - res <- pecotmr:::metaRandomEffects(means, ses) + res <- pecotmr:::.rmaMeta(means, ses) # Fixed-effect weights w_fe <- 1 / ses^2 @@ -1370,7 +1370,7 @@ test_that("gldscUnivariate with annotations returns scoreStats", { # # Targets the specific uncovered branches in R/h2EstimationWrappers.R: # bplapplyBlocks, checkGenomeBuild (unknown type), weightedLsRidge -# (vector X ridge path), metaRandomEffects (length mismatch), .fglsSolve +# (vector X ridge path), .rmaMeta (length mismatch), .fglsSolve # (diagonal path), .gldscLocal (fine-grained blocks), .hdlLocal (p<3 and # tau=NULL), .lderLocalH2 (small block + baseline path), .hdlSeFisher- # Stratified / .hdlJackknifeTau (lambda>0 + singular fallback), the @@ -1457,12 +1457,12 @@ test_that("weightedLsRidge converts a vector X to a matrix in the ridge path", { }) # --------------------------------------------------------------------------- -# metaRandomEffects — length-mismatch error +# .rmaMeta — length-mismatch error # --------------------------------------------------------------------------- -test_that("metaRandomEffects errors when means and ses differ in length", { +test_that(".rmaMeta errors when means and ses differ in length", { expect_error( - pecotmr:::metaRandomEffects(c(1, 2), c(1, 2, 3)), + pecotmr:::.rmaMeta(c(1, 2), c(1, 2, 3)), "must have the same length" ) }) diff --git a/tests/testthat/test_jointEngine.R b/tests/testthat/test_jointEngine.R index e258218a..c0cd5419 100644 --- a/tests/testthat/test_jointEngine.R +++ b/tests/testthat/test_jointEngine.R @@ -26,7 +26,7 @@ .je_mockPostprocess <- function(fit, method, dataX, dataY, coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, region = NULL, - conditionIdx = NULL) { + conditionIdx = NULL, ...) { vids <- colnames(dataX) FineMappingEntry( variantIds = vids, @@ -57,6 +57,42 @@ test_that(".runJointCell: cross-context FM expands to per-context rows", { expect_equal(as.character(res$jointContexts), rep("c1;c2", 4L)) # provenance }) +test_that(".runJointCell (mvsusie): fullFit config threads to postprocess", { + # The joint engine's fitJointGroup frame does not lexically see the pipeline + # method's fullFit params, so they must ride the FmJointPipeline config. + # Assert the three flags reach .fmPostprocessOne verbatim (buildTopLoci's own + # fullFit column construction is covered in test_fineMappingWrappers.R). + set.seed(1) + cell <- .je_synthCell(list(.je_mkGroup("G1"))) + pipe <- new("FmJointPipeline", config = list( + coverage = 0.95, cvFolds = 0, + fullFit = TRUE, fullFitAlphaOnly = FALSE, includeAllCs = TRUE)) + local_mocked_bindings(create_mixture_prior = function(...) "PRIOR", + .package = "mvsusieR") + captured <- new.env(parent = emptyenv()) + capturingPostprocess <- function(fit, method, dataX, dataY, coverage, + secondaryCoverage, signalCutoff, minAbsCorr, + csInput = NULL, af = NULL, region = NULL, + conditionIdx = NULL, fullFit = NULL, + fullFitAlphaOnly = NULL, includeAllCs = NULL, + ...) { + captured$fullFit <- fullFit + captured$fullFitAlphaOnly <- fullFitAlphaOnly + captured$includeAllCs <- includeAllCs + .je_mockPostprocess(fit, method, dataX, dataY, coverage, secondaryCoverage, + signalCutoff, minAbsCorr, csInput = csInput, af = af, + region = region, conditionIdx = conditionIdx) + } + local_mocked_bindings(fitMvsusie = function(...) list(), + .fmPostprocessOne = capturingPostprocess, + .package = "pecotmr") + pecotmr:::.runJointCell(cell, pipe, data = NULL, scope = NULL, + tokens = "mvsusie") + expect_true(isTRUE(captured$fullFit)) # threaded, not the FALSE default + expect_false(isTRUE(captured$fullFitAlphaOnly)) # widen all four matrices + expect_true(isTRUE(captured$includeAllCs)) # keep filtered-out CS +}) + test_that(".runJointCell: cross-context FM uses the per-fold mr.mash CV prior", { set.seed(2) cell <- .je_synthCell(list(.je_mkGroup("G1"))) diff --git a/tests/testthat/test_jointSpecification.R b/tests/testthat/test_jointSpecification.R index cbaa4bed..007b1437 100644 --- a/tests/testthat/test_jointSpecification.R +++ b/tests/testthat/test_jointSpecification.R @@ -662,7 +662,7 @@ context("joint dispatchers (fineMappingDispatcher / twasDispatcher)") .jd_mockPostprocess <- function() { function(fit, method, dataX, dataY, coverage, secondaryCoverage, signalCutoff, minAbsCorr, csInput = NULL, af = NULL, - region = NULL, conditionIdx = NULL) { + region = NULL, conditionIdx = NULL, ...) { if (is.matrix(dataX)) { vids <- colnames(dataX) } else if (is.list(dataY) && !is.null(dataY$z)) { diff --git a/tests/testthat/test_mashPipeline.R b/tests/testthat/test_mashPipeline.R index acfbe019..7cf383a9 100644 --- a/tests/testthat/test_mashPipeline.R +++ b/tests/testthat/test_mashPipeline.R @@ -2,7 +2,7 @@ # Tests for utility helpers exported from R/mashPipeline.R that don't # require mashr / flashier installs: # sanitizeMashData, makePairwiseContrastCol, sliceMashData, -# metaAnalysisPerCell +# metaAnalysisPerCondition # ============================================================================= # --------------------------------------------------------------------------- @@ -117,18 +117,18 @@ test_that("sliceMashData restricts data$snp to intersection of snps argument", { }) # --------------------------------------------------------------------------- -# metaAnalysisPerCell +# metaAnalysisPerCondition # --------------------------------------------------------------------------- -test_that("metaAnalysisPerCell returns single-effect p-value when only one feature passes filter", { +test_that("metaAnalysisPerCondition returns single-effect p-value when only one feature passes filter", { feat <- "var1" cols <- c("mean_contrast_brain_vs_blood") es <- matrix(0.5, nrow = 1, ncol = 1, dimnames = list(feat, cols)) se <- matrix(0.1, nrow = 1, ncol = 1, dimnames = list(feat, cols)) - out <- metaAnalysisPerCell(es, se) + out <- metaAnalysisPerCondition(es, se) # 2 conditions: brain, blood -> 2 rows expect_equal(nrow(out), 2L) - expect_true(all(c("cell", "condition", "meta_pvalue", + expect_true(all(c("condition", "contrast", "meta_pvalue", "meta_effect", "meta_se", "tau2", "I2") %in% names(out))) # With a single effect both rows return single-effect p-values (not NA) expect_false(any(is.na(out$meta_pvalue))) @@ -137,23 +137,23 @@ test_that("metaAnalysisPerCell returns single-effect p-value when only one featu expect_true(all(is.na(out$I2))) }) -test_that("metaAnalysisPerCell returns NA pvalue when SE cutoff drops everything", { +test_that("metaAnalysisPerCondition returns NA pvalue when SE cutoff drops everything", { feat <- c("v1", "v2") cols <- "mean_contrast_brain_vs_blood" es <- matrix(c(0.1, 0.2), nrow = 2, ncol = 1, dimnames = list(feat, cols)) se <- matrix(c(0.01, 0.02), nrow = 2, ncol = 1, dimnames = list(feat, cols)) # seCutoff = 0.5 drops both rows - out <- metaAnalysisPerCell(es, se, seCutoff = 0.5) + out <- metaAnalysisPerCondition(es, se, seCutoff = 0.5) expect_true(all(is.na(out$meta_pvalue))) expect_true(all(is.na(out$meta_effect))) }) -test_that("metaAnalysisPerCell runs DerSimonian-Laird when >=2 effects survive", { +test_that("metaAnalysisPerCondition runs DerSimonian-Laird when >=2 effects survive", { feat <- c("v1", "v2", "v3") cols <- "mean_contrast_brain_vs_blood" es <- matrix(c(0.3, 0.5, 0.4), nrow = 3, ncol = 1, dimnames = list(feat, cols)) se <- matrix(c(0.1, 0.1, 0.1), nrow = 3, ncol = 1, dimnames = list(feat, cols)) - out <- metaAnalysisPerCell(es, se) + out <- metaAnalysisPerCondition(es, se) expect_equal(nrow(out), 2L) # All three effects survive (SE = 0.1 > 0): meta_effect and meta_se populated expect_false(any(is.na(out$meta_effect))) @@ -164,7 +164,7 @@ test_that("metaAnalysisPerCell runs DerSimonian-Laird when >=2 effects survive", expect_true(all(out$I2 >= 0 & out$I2 <= 1)) }) -test_that("metaAnalysisPerCell unique-cells extraction handles >2 conditions", { +test_that("metaAnalysisPerCondition unique-condition extraction handles >2 conditions", { feat <- "v1" cols <- c( "mean_contrast_brain_vs_blood", @@ -172,9 +172,9 @@ test_that("metaAnalysisPerCell unique-cells extraction handles >2 conditions", { "mean_contrast_blood_vs_muscle") es <- matrix(c(0.3, 0.4, 0.1), nrow = 1, dimnames = list(feat, cols)) se <- matrix(c(0.1, 0.1, 0.1), nrow = 1, dimnames = list(feat, cols)) - out <- metaAnalysisPerCell(es, se) - # 3 cells (brain, blood, muscle), each with 2 vs-comparisons -> 6 rows - expect_setequal(unique(out$cell), c("brain", "blood", "muscle")) + out <- metaAnalysisPerCondition(es, se) + # 3 conditions (brain, blood, muscle), each with 2 vs-comparisons -> 6 rows + expect_setequal(unique(out$condition), c("brain", "blood", "muscle")) expect_equal(nrow(out), 6L) }) @@ -335,20 +335,20 @@ test_that("updateMashModelCov slices named data-driven cov matrices by sample", }) # --------------------------------------------------------------------------- -# metaAnalysisPerCell — cells matching no contrast column are skipped +# metaAnalysisPerCondition — conditions matching no contrast column are skipped # --------------------------------------------------------------------------- -test_that("metaAnalysisPerCell skips cells whose name matches no column", { - # The condition "x$y" yields a derived cell name "x$y"; used as a grep() - # pattern the embedded `$` anchor matches nothing, exercising the - # `if (length(cellIdx) == 0) next` skip branch. +test_that("metaAnalysisPerCondition skips conditions whose name matches no column", { + # The condition "x$y" is a derived condition name; used as a grep() pattern + # the embedded `$` anchor matches nothing, exercising the + # `if (length(idx) == 0) next` skip branch. cols <- "mean_contrast_x$y_vs_z" es <- matrix(c(0.3, 0.5), nrow = 2, dimnames = list(c("v1", "v2"), cols)) se <- matrix(c(0.1, 0.1), nrow = 2, dimnames = list(c("v1", "v2"), cols)) - out <- metaAnalysisPerCell(es, se) - # "x$y" is skipped; only the "z" cell survives. - expect_false("x$y" %in% out$cell) - expect_true("z" %in% out$cell) + out <- metaAnalysisPerCondition(es, se) + # "x$y" is skipped; only the "z" condition survives. + expect_false("x$y" %in% out$condition) + expect_true("z" %in% out$condition) expect_equal(nrow(out), 1L) }) @@ -468,3 +468,656 @@ test_that("mashPipeline estimates Vhat from a null set and defaults nPcs", { logical(1)))) expect_equal(sum(res$w), 1, tolerance = 1e-6) }) + +# --------------------------------------------------------------------------- +# mashResidualCorrelation — the Vhat estimator extracted from mashPipeline. +# --------------------------------------------------------------------------- + +test_that("mashResidualCorrelation(identity) is an identity of the right size", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + v <- mashResidualCorrelation(list(strong = ss), alpha = 0, method = "identity") + expect_equal(dim(v), c(3L, 3L)) + expect_equal(v, diag(3)) +}) + +test_that("mashResidualCorrelation(simple) returns a null correlation matrix", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + v <- suppressMessages(suppressWarnings( + mashResidualCorrelation(list(strong = ss, null = ss), + alpha = 0, method = "simple"))) + expect_equal(dim(v), c(3L, 3L)) + expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-8) # a correlation matrix + expect_true(isSymmetric(unname(v))) +}) + +test_that("mashResidualCorrelation(simple) errors without a null entry", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashResidualCorrelation(list(strong = ss), alpha = 0, method = "simple"), + "requires a 'null' entry") +}) + +test_that("mashResidualCorrelation(simple_specific) returns a null correlation", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + v <- suppressMessages(suppressWarnings( + mashResidualCorrelation(list(strong = ss, null = ss), + alpha = 0, method = "simple_specific"))) + expect_equal(dim(v), c(3L, 3L)) + expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-6) +}) + +test_that("mashResidualCorrelation(corshrink) returns a 3x3 correlation matrix", { + skip_if_not_installed("mashr") + skip_if_not_installed("CorShrink") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + v <- suppressMessages(suppressWarnings( + mashResidualCorrelation(list(strong = ss, null = ss), + alpha = 0, method = "corshrink"))) + expect_equal(dim(v), c(3L, 3L)) + expect_equal(unname(diag(v)), rep(1, 3), tolerance = 1e-6) +}) + +test_that("mashResidualCorrelation(mle) refines V against a supplied prior", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + v <- suppressMessages(suppressWarnings( + mashResidualCorrelation(list(strong = ss, random = ss), alpha = 0, + method = "mle", + priorCovariances = list(identity = diag(3)), + nSubset = 100L, maxIter = 3L, setSeed = 1L))) + expect_equal(dim(v), c(3L, 3L)) +}) + +test_that("mashResidualCorrelation errors when a method's inputs are missing", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error(mashResidualCorrelation(list(strong = ss), alpha = 0, + method = "corshrink"), + "requires a 'null'") + expect_error(mashResidualCorrelation(list(strong = ss, random = ss), + alpha = 0, method = "mle"), + "priorCovariances") +}) + +# --------------------------------------------------------------------------- +# mashPriorCovariances — the covariance + weight estimator extracted from +# mashPipeline. Default builds every non-udr component (canonical + pca + +# flash + flash_nonneg) refined by cov_ed. +# --------------------------------------------------------------------------- + +test_that("mashPriorCovariances computes the default (all-but-udr) prior", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + nPcs = 2L, setSeed = 1L))) + expect_named(pc, c("U", "w", "loglik")) + expect_gt(length(pc$U), 0L) + expect_true(all(vapply(pc$U, + function(m) all(dim(m) == c(3L, 3L)), + logical(1)))) + expect_equal(sum(pc$w), 1, tolerance = 1e-6) + expect_null(pc$loglik) +}) + +test_that("mashPriorCovariances passes a supplied prior through unchanged", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + U0 <- list(identity = diag(3), effectA = diag(c(1, 0, 0))) + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + priorCovariances = U0))) + expect_identical(pc$U, U0) + expect_equal(sum(pc$w), 1, tolerance = 1e-6) +}) + +test_that("mashPriorCovariances validates a supplied prior", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error(suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + priorCovariances = list()))), + "non-empty named") + expect_error(suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + priorCovariances = list(myU = diag(2))))), + "3 x 3 matrix") +}) + +test_that("mashPriorCovariances(flash_nonneg) adds components vs flash-only", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + base <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + components = c("canonical", "pca", "flash"), + nPcs = 2L, setSeed = 1L))) + wide <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + components = c("canonical", "pca", "flash", "flash_nonneg"), + nPcs = 2L, setSeed = 1L))) + expect_gt(length(wide$U), length(base$U)) +}) + +test_that("mashPriorCovariances engine 'ud' (udr) produces U + weights", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + skip_if_not_installed("udr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + # A toy-sized udr config: `n_unconstrained` dominates the cost, and the default + # (50, sized for many-condition data) is pathological on a 3-condition fixture + # (it drove a 5+ minute fit). 2 unconstrained matrices suffice to exercise the + # udr path. + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + engine = "ud", + udControl = list(n_unconstrained = 2L, maxiter = 20L), + setSeed = 1L))) + expect_gt(length(pc$U), 0L) + expect_true(all(vapply(pc$U, function(m) all(dim(m) == c(3L, 3L)), logical(1)))) + expect_equal(sum(pc$w), 1, tolerance = 1e-6) +}) + +test_that("mashPriorCovariances engine 'ud_ted' errors clearly on non-i.i.d. data", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + skip_if_not_installed("udr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error(suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + engine = "ud_ted", setSeed = 1L))), + "i.i.d") +}) + +test_that("mashPriorCovariances rejects an unknown component", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashPriorCovariances(list(strong = ss), alpha = 0, components = "bogus"), + "unknown component") +}) + +# --------------------------------------------------------------------------- +# mashCovarianceComponents — the raw per-method component builder that +# mashPriorCovariances refines (and the mixture-prior notebook demonstrates). +# --------------------------------------------------------------------------- + +test_that("mashCovarianceComponents builds a single requested component", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + fl <- suppressMessages(suppressWarnings( + mashCovarianceComponents(list(strong = ss), alpha = 0, vhat = diag(3), + components = "flash", setSeed = 1L))) + expect_gt(length(fl), 0L) + expect_true(all(vapply(fl, function(m) all(dim(m) == c(3L, 3L)), logical(1)))) +}) + +test_that("mashCovarianceComponents default builds all non-udr components", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + one <- suppressMessages(suppressWarnings( + mashCovarianceComponents(list(strong = ss), alpha = 0, vhat = diag(3), + components = "canonical", setSeed = 1L))) + all4 <- suppressMessages(suppressWarnings( + mashCovarianceComponents(list(strong = ss), alpha = 0, vhat = diag(3), + nPcs = 2L, setSeed = 1L))) + expect_gt(length(all4), length(one)) +}) + +test_that("mashCovarianceComponents feeds mashPriorCovariances (same components)", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + comps <- suppressMessages(suppressWarnings( + mashCovarianceComponents(list(strong = ss), alpha = 0, vhat = diag(3), + nPcs = 2L, setSeed = 1L))) + prior <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + nPcs = 2L, setSeed = 1L))) + # mashPriorCovariances refines these components, so its U contains them all. + expect_true(all(names(comps) %in% names(prior$U))) +}) + +test_that("mashCovarianceComponents rejects unknown components", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashCovarianceComponents(list(strong = ss), alpha = 0, components = "bogus"), + "unknown component") +}) + +test_that("mashPriorCovariances refines supplied priorComponents (pipeline mode)", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + comps <- suppressMessages(suppressWarnings( + mashCovarianceComponents(list(strong = ss), alpha = 0, vhat = diag(3), + nPcs = 2L, setSeed = 1L))) + pr <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = diag(3), + priorComponents = comps, engine = "cov_ed", + setSeed = 1L))) + # the supplied components are refined into the returned U (not rebuilt) + expect_true(all(names(comps) %in% names(pr$U))) + expect_equal(sum(pr$w), 1, tolerance = 1e-6) +}) + +test_that("mashPriorCovariances validates priorComponents", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashPriorCovariances(list(strong = ss), alpha = 0, priorComponents = list()), + "non-empty named") +}) + +test_that("mashPipeline result == composing the two extracted building blocks", { + skip_if_not_installed("mashr") + skip_if_not_installed("flashier") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + full <- suppressMessages(suppressWarnings( + mashPipeline(list(strong = ss, random = ss, null = ss), + alpha = 0, setSeed = 1L))) + # Same seed discipline mashPipeline uses: seed once, then delegate with + # setSeed = NULL so the RNG stream stays continuous. + set.seed(1L) + vhat <- mashResidualCorrelation(list(strong = ss, null = ss), alpha = 0, + method = "simple", setSeed = NULL) + prior <- suppressMessages(suppressWarnings( + mashPriorCovariances(list(strong = ss), alpha = 0, vhat = vhat, + setSeed = NULL))) + expect_equal(full$U, prior$U) + expect_equal(full$w, prior$w) +}) + +# --------------------------------------------------------------------------- +# mashModelFit + mashPosterior — the fit -> posterior chain (mash_fit / +# mash_posterior). A tiny 2-component prior keeps these fast. +# --------------------------------------------------------------------------- + +.mashTestModel <- function(ss) { + suppressMessages(suppressWarnings( + mashModelFit(list(random = ss), alpha = 0, + priorCovariances = list(identity = diag(3), + effectA = diag(c(1, 0, 0))), + vhat = diag(3), setSeed = 1L))) +} + +test_that("mashModelFit returns a fitted mash model", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + m <- .mashTestModel(ss) + expect_s3_class(m, "mash") + expect_false(is.null(m$fitted_g)) +}) + +test_that("mashModelFit validates the prior and the fitOn entry", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error(mashModelFit(list(random = ss), alpha = 0, + priorCovariances = list()), + "non-empty named list") + expect_error(mashModelFit(list(strong = ss), alpha = 0, + priorCovariances = list(identity = diag(3))), + "no 'random' entry") +}) + +test_that("mashPosterior returns posterior matrices with covariance", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + post <- suppressMessages(suppressWarnings( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)))) + expect_true(all(c("PosteriorMean", "PosteriorSD", "lfsr", "PosteriorCov") + %in% names(post))) + expect_equal(ncol(post$PosteriorMean), 3L) + expect_equal(nrow(post$PosteriorMean), nrow(post$PosteriorSD)) +}) + +test_that("mashPosterior outputPosteriorCov = FALSE omits PosteriorCov", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + post <- suppressMessages(suppressWarnings( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3), + outputPosteriorCov = FALSE))) + expect_false("PosteriorCov" %in% names(post)) + expect_equal(ncol(post$PosteriorMean), 3L) +}) + +test_that("mashPosterior(excludeCondition) drops the condition from model + output", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) + post <- suppressMessages(suppressWarnings( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3), + excludeCondition = conds[3]))) + expect_equal(ncol(post$PosteriorMean), 2L) + expect_false(conds[3] %in% colnames(post$PosteriorMean)) +}) + +test_that("mashPosterior errors on an unknown excludeCondition", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3), + excludeCondition = "not_a_condition"), + "not found in the target") +}) + +test_that("fitMashContrast consumes a mashPosterior result", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + post <- suppressMessages(suppressWarnings( + mashPosterior(.mashTestModel(ss), ss, alpha = 0, vhat = diag(3)))) + # Force all 3 conditions "tested" (non-zero orig) so a contrast is returned. + om <- post$PosteriorMean + om[om == 0] <- 0.01 + fc <- fitMashContrast(1L, om, post$PosteriorMean, post$PosteriorCov) + expect_s3_class(fc, "data.frame") + expect_equal(nrow(fc), 1L) +}) + +# --------------------------------------------------------------------------- +# .rmaMeta: thin metafor::rma adapter (DL default; REML/ML/... pass through) +# --------------------------------------------------------------------------- + +test_that(".rmaMeta: DL is the default and reshapes the metafor fit", { + set.seed(1); m <- rnorm(6); s <- abs(rnorm(6)) + 0.2 + expect_equal(pecotmr:::.rmaMeta(m, s), + pecotmr:::.rmaMeta(m, s, method = "DL")) + out <- pecotmr:::.rmaMeta(m, s) + expect_true(all(c("mean", "se", "tau2", "I2", "Q") %in% names(out))) + expect_true(out$I2 >= 0 && out$I2 <= 1) # metafor's % rescaled to [0,1] +}) + +test_that(".rmaMeta: DL matches the closed-form DerSimonian-Laird", { + means <- c(0.5, 0.8, 0.3); ses <- c(0.2, 0.3, 0.15) + res <- pecotmr:::.rmaMeta(means, ses) + wFe <- 1 / ses^2; muFe <- sum(wFe * means) / sum(wFe) + Q <- sum(wFe * (means - muFe)^2) + tau2 <- max(0, (Q - 2) / (sum(wFe) - sum(wFe^2) / sum(wFe))) + wRe <- 1 / (ses^2 + tau2) + expect_equal(res$Q, Q, tolerance = 1e-6) + expect_equal(res$tau2, tau2, tolerance = 1e-6) + expect_equal(res$mean, sum(wRe * means) / sum(wRe), tolerance = 1e-6) + expect_equal(res$se, sqrt(1 / sum(wRe)), tolerance = 1e-6) +}) + +test_that(".rmaMeta: non-DL estimator (REML) runs via metafor and differs from DL", { + set.seed(3); m <- rnorm(8, sd = 1.5); s <- abs(rnorm(8)) + 0.3 + reml <- pecotmr:::.rmaMeta(m, s, method = "REML") + expect_true(all(c("mean", "se", "tau2", "I2", "Q") %in% names(reml))) + expect_true(reml$I2 >= 0 && reml$I2 <= 1) + # REML tau2 generally differs from DL tau2 on heterogeneous data + expect_false(isTRUE(all.equal(reml$tau2, pecotmr:::.rmaMeta(m, s)$tau2))) +}) + +test_that(".rmaMeta: non-DL estimator falls back to DL on non-convergence (never errors)", { + # metafor's iterative estimators can fail to converge on small / degenerate + # inputs; .rmaMeta must still return a finite fit (via the DL fallback). + set.seed(1) + for (i in seq_len(25)) { + m <- rnorm(sample(3:8, 1L)); s <- abs(rnorm(length(m))) + 0.1 + r <- suppressWarnings(pecotmr:::.rmaMeta(m, s, method = "REML")) + expect_true(is.finite(r$mean) && is.finite(r$se)) + } +}) + +test_that("metaAnalysisPerCondition: threads metaMethod (DL default unchanged)", { + es <- matrix(rnorm(12), 6, 2, + dimnames = list(NULL, c("mean_contrast_A_vs_B", "mean_contrast_A_vs_C"))) + sv <- matrix(abs(rnorm(12)) + 0.1, 6, 2, dimnames = dimnames(es)) + expect_equal(metaAnalysisPerCondition(es, sv), + metaAnalysisPerCondition(es, sv, metaMethod = "DL")) +}) + +# --------------------------------------------------------------------------- +# mashPosteriorContrast (orchestrates fitMashContrast over all features) +# --------------------------------------------------------------------------- + +.mpc_fixture <- function(nf = 5, conds = c("Ast", "Mic", "Oli"), seed = 1) { + set.seed(seed) + pm <- matrix(rnorm(nf * length(conds)), nf, length(conds), + dimnames = list(paste0("chr1:", seq_len(nf), ":A:G"), conds)) + pv <- array(0, c(length(conds), length(conds), nf), + dimnames = list(conds, conds, NULL)) + for (i in seq_len(nf)) { A <- matrix(rnorm(length(conds)^2), length(conds)); pv[, , i] <- crossprod(A) } + orig <- matrix(rnorm(nf * length(conds)), nf, length(conds), dimnames = list(rownames(pm), conds)) + list(pm = pm, pv = pv, orig = orig) +} + +test_that("mashPosteriorContrast: deviation + pairwise columns, rownames preserved", { + f <- .mpc_fixture() + res <- mashPosteriorContrast(f$pm, f$pv, f$orig) + expect_equal(nrow(res), 5L) + expect_identical(rownames(res), rownames(f$pm)) + # 3 conditions -> 3 deviation + 3 pairwise = 6 contrasts x (mean/se/p) + expect_equal(sum(grepl("^mean_contrast", names(res))), 6L) + expect_equal(sum(grepl("^se_contrast", names(res))), 6L) + expect_equal(sum(grepl("^p_contrast", names(res))), 6L) + expect_true(any(grepl("deviation", names(res))) && any(grepl("_vs_", names(res)))) + # column order: all mean_* precede se_*, which precede p_* + kinds <- sub("_contrast_.*", "", names(res)) + expect_false(is.unsorted(match(kinds, c("mean", "se", "p")))) +}) + +test_that("mashPosteriorContrast: features with < 2 tested conditions are dropped", { + f <- .mpc_fixture() + f$orig[2, ] <- 0 # feature 2 has no tested condition + f$orig[4, c(2, 3)] <- 0 # feature 4 has only 1 tested condition + res <- mashPosteriorContrast(f$pm, f$pv, f$orig) + expect_equal(nrow(res), 3L) + expect_false(any(rownames(res) %in% rownames(f$pm)[c(2, 4)])) +}) + +test_that("mashPosteriorContrast: grouping is forwarded to fitMashContrast", { + f <- .mpc_fixture() + res <- mashPosteriorContrast(f$pm, f$pv, f$orig, + grouping = c(Ast = 1L, Mic = 1L, Oli = 0L)) + expect_equal(nrow(res), 5L) + expect_true(any(grepl("deviation", names(res)))) +}) + +# --------------------------------------------------------------------------- +# Feature scores (calculateFeatureScores / nSignificantScore / scoreFromCs) +# --------------------------------------------------------------------------- + +.fs_contrast <- function(nf = 8, conds = c("Ast", "Mic", "Oli"), seed = 1) { + f <- .mpc_fixture(nf = nf, conds = conds, seed = seed) + mashPosteriorContrast(f$pm, f$pv, f$orig) +} + +test_that("calculateFeatureScores: one Z per condition from deviation contrasts", { + cr <- .fs_contrast() + fs <- calculateFeatureScores(cr, metaMethod = "REML") + expect_setequal(fs$condition, c("Ast", "Mic", "Oli")) + expect_equal(names(fs), c("condition", "zScore")) + expect_true(all(is.finite(fs$zScore))) + # empty when no deviation columns + expect_equal(nrow(calculateFeatureScores(data.frame(x = 1))), 0L) +}) + +test_that("nSignificantScore: fraction of significant deviation contrasts in [0,1]", { + cr <- .fs_contrast() + ns <- nSignificantScore(cr, pCutoff = 0.5) + expect_setequal(ns$condition, c("Ast", "Mic", "Oli")) + expect_true(all(ns$ratio >= 0 & ns$ratio <= 1, na.rm = TRUE)) + # a hand-built p column: 2 of 4 below cutoff -> 0.5 + df <- data.frame(p_contrast_A_deviation = c(1e-8, 1e-9, 0.2, 0.3)) + expect_equal(nSignificantScore(df, pCutoff = 1e-5)$ratio, 0.5) +}) + +test_that("scoreFromCs: CS lead intersection score; NA on empty / no-overlap", { + cr <- .fs_contrast() + fm <- data.frame(variants = rownames(cr), + cs_order = c(1, 1, 1, 2, 2, 0, 0, 0), + pip = c(0.6, 0.3, 0.1, 0.7, 0.3, 0.02, 0.02, 0.02), + stringsAsFactors = FALSE) + sc <- scoreFromCs(fm, cr, "Ast") + expect_true(is.finite(sc) && sc >= 0) + # no credible sets -> NA + expect_true(is.na(scoreFromCs( + data.frame(variants = character(0), cs_order = integer(0), pip = numeric(0)), + cr, "Ast"))) + # CS leads that don't overlap the contrast variants -> NA + fmNoOverlap <- data.frame(variants = c("chrX:1:A:G", "chrX:2:A:G"), + cs_order = c(1, 1), pip = c(0.9, 0.1), + stringsAsFactors = FALSE) + expect_true(is.na(scoreFromCs(fmNoOverlap, cr, "Ast"))) +}) + +# --------------------------------------------------------------------------- +# Coverage: feature-score edge branches + posterior-contrast empty result +# --------------------------------------------------------------------------- + +test_that("calculateFeatureScores: NA when a condition's se column is absent", { + cr <- data.frame(mean_contrast_Ast_deviation = c(1, 2), + row.names = c("v1", "v2")) + out <- calculateFeatureScores(cr) + expect_equal(out$condition, "Ast") + expect_true(is.na(out$zScore)) +}) + +test_that("calculateFeatureScores: NA when no finite (effect, se) pair remains", { + cr <- data.frame(mean_contrast_Ast_deviation = c(1, 2), + se_contrast_Ast_deviation = c(0, -1)) # se <= 0 -> all dropped + expect_true(is.na(calculateFeatureScores(cr)$zScore)) +}) + +test_that("nSignificantScore: empty result when there are no deviation p-value columns", { + out <- nSignificantScore(data.frame(foo = 1:3, bar = 4:6)) + expect_equal(nrow(out), 0L) + expect_named(out, c("condition", "ratio")) +}) + +test_that("scoreFromCs: falls back to the single pairwise contrast when no deviation column", { + fm <- data.frame(cs_order = c(1, 1, 0), pip = c(0.9, 0.5, 0.1), + variants = c("v1", "v2", "v3"), stringsAsFactors = FALSE) + cr <- data.frame(p_contrast_Ast_vs_Mic = c(0.5, 0.2), + mean_contrast_Ast_vs_Mic = c(1.0, 0.5), + se_contrast_Ast_vs_Mic = c(0.2, 0.1), + row.names = c("v1", "v2")) + # condition "Xyz" has no deviation column; exactly one pairwise contrast exists. + expect_true(is.finite(scoreFromCs(fm, cr, condition = "Xyz"))) +}) + +test_that("scoreFromCs: NA when neither a deviation nor a single pairwise column exists", { + fm <- data.frame(cs_order = c(1, 0), pip = c(0.9, 0.1), + variants = c("v1", "v2"), stringsAsFactors = FALSE) + # Lead variant overlaps, but cr carries no p_contrast_*_deviation for the + # condition and no pairwise p_contrast_*_vs_* column -> NA. + cr <- data.frame(some_other_col = 1, row.names = "v1") + expect_true(is.na(scoreFromCs(fm, cr, condition = "Xyz"))) +}) + +test_that("mashPosteriorContrast: empty frame when every feature is dropped", { + f <- .mpc_fixture() + f$orig[] <- 0 # no feature has any tested condition + expect_equal(nrow(mashPosteriorContrast(f$pm, f$pv, f$orig)), 0L) +}) + +# --------------------------------------------------------------------------- +# Coverage: mash* helpers — NULL vhat default, SimpleList input, error guards +# --------------------------------------------------------------------------- + +test_that("mashResidualCorrelation(mle): errors without a 'random' entry", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + expect_error( + mashResidualCorrelation(list(strong = ss), alpha = 0, method = "mle"), + "requires a 'random' entry") +}) + +test_that("mashResidualCorrelation accepts a SimpleList sumStatsList", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + V <- suppressMessages(suppressWarnings( + mashResidualCorrelation(S4Vectors::SimpleList(null = ss), alpha = 0, + method = "simple"))) + expect_equal(dim(V), c(3L, 3L)) +}) + +test_that("mashCovarianceComponents: SimpleList input + default (NULL) vhat", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + cc <- suppressMessages(suppressWarnings( + mashCovarianceComponents(S4Vectors::SimpleList(strong = ss), alpha = 0, + components = "canonical", setSeed = 1L))) + expect_gt(length(cc), 0L) +}) + +test_that("mashPriorCovariances: SimpleList input (canonical only)", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + pc <- suppressMessages(suppressWarnings( + mashPriorCovariances(S4Vectors::SimpleList(strong = ss), alpha = 0, + vhat = diag(3), components = "canonical"))) + expect_named(pc, c("U", "w", "loglik")) +}) + +test_that("mashModelFit: SimpleList input + default (NULL) vhat", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + m <- suppressMessages(suppressWarnings( + mashModelFit(S4Vectors::SimpleList(random = ss), alpha = 0, + priorCovariances = list(identity = diag(3)), setSeed = 1L))) + expect_s3_class(m, "mash") +}) + +test_that("mashPosterior: default (NULL) vhat and excludeCondition dropping every condition", { + skip_if_not_installed("mashr") + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + model <- .mashTestModel(ss) + conds <- colnames(.mashSumStatsToMatrices(ss, "strong")$b) + # NULL vhat path: omit vhat so mashPosterior fills the identity default. + post <- suppressMessages(suppressWarnings(mashPosterior(model, ss, alpha = 0))) + expect_equal(ncol(post$PosteriorMean), 3L) + # excludeCondition removing every condition errors. + expect_error(suppressMessages(suppressWarnings( + mashPosterior(model, ss, alpha = 0, excludeCondition = conds))), + "drops every condition") +}) diff --git a/tests/testthat/test_mashWrapper.R b/tests/testthat/test_mashWrapper.R index f5f33d0c..0224dd42 100644 --- a/tests/testthat/test_mashWrapper.R +++ b/tests/testthat/test_mashWrapper.R @@ -726,6 +726,68 @@ test_that(".mashSumStatsToMatrices: errors when no usable scale", { "no usable scale") }) +test_that(".mashSumStatsToMatrices: inputScale='z' errors when Z missing", { + ss <- .mssm_makeQtlSumStats(function(i, n) + list(SNP = paste0("v", seq_len(n)), A1 = "A", A2 = "G", + BETA = rnorm(n, sd = 0.1), + SE = abs(rnorm(n, sd = 0.05)) + 0.01)) # BETA/SE but no Z + expect_error( + pecotmr:::.mashSumStatsToMatrices(ss, "strong", inputScale = "z"), + "carry a Z mcol") +}) + +# =========================================================================== +# .mashObjectMatrices / .mashObjectPartitions +# =========================================================================== + +test_that(".mashObjectMatrices errors when marginal effects lack the required columns", { + res <- QtlFineMappingResult(study = "s", context = "brain", trait = "t", + method = "susie", entry = list(.sc_makeFineMappingEntry(3))) + # Force a marginal-effects table with no `context` column (as an mv/f-SuSiE + # result trimmed of marginal sumstats would yield): mash cannot pivot it. + testthat::local_mocked_bindings( + getMarginalEffects = function(x, ...) data.frame(variant_id = "v", beta = 1, se = 1), + .package = "pecotmr") + expect_error( + pecotmr:::.mashObjectMatrices(res, inputScale = "auto", coverage = 0.95), + ">= 2 contexts") +}) + +test_that(".mashObjectMatrices warns and pins the first method on a multi-method result", { + res <- QtlFineMappingResult( + study = c("s", "s"), context = c("brain", "liver"), trait = c("t", "t"), + method = c("susie", "mvsusie"), + entry = list(.sc_makeFineMappingEntry(3), .sc_makeFineMappingEntry(3))) + expect_warning( + pecotmr:::.mashObjectMatrices(res, inputScale = "auto", coverage = 0.95), + "multiple methods") +}) + +test_that(".mashObjectPartitions errors when < 2 conditions remain after excludeCondition", { + ss <- .mssm_makeQtlSumStats(function(i, n) + list(SNP = paste0("v", seq_len(n)), A1 = "A", A2 = "G", + BETA = rnorm(n, sd = 0.1), SE = abs(rnorm(n, sd = 0.05)) + 0.01)) + expect_error( + pecotmr:::.mashObjectPartitions(ss, nRandom = 3, nNull = 3, + excludeCondition = "liver", coverage = 0.95, inputScale = "auto", seed = 1), + "fewer than 2 conditions") +}) + +test_that(".mashObjectPartitions warns when no variants match the independent-variant list", { + ss <- .mssm_makeQtlSumStats(function(i, n) + list(SNP = paste0("v", seq_len(n)), A1 = "A", A2 = "G", + BETA = rnorm(n, sd = 0.1), SE = abs(rnorm(n, sd = 0.05)) + 0.01)) + # No independent variant matches the panel, so the random/null background is + # empty for this object; the warning fires before the (empty) sampling. + expect_warning( + tryCatch( + pecotmr:::.mashObjectPartitions(ss, nRandom = 2, nNull = 2, + excludeCondition = character(0), coverage = 0.95, inputScale = "auto", + seed = 1, independentVariants = c("chrX:999999:N:N")), + error = function(e) invisible(NULL)), + "no variants matched") +}) + # =========================================================================== # .mashSumStatsToMatrices — matrix assembly behaviour (NA fill, # rowname disambiguation, multi-context shape) on the bundled fixture @@ -1041,3 +1103,206 @@ test_that("qtlSumStatsFromZMatrix: rejects non-matrix input and unlabelled condi expect_error(qtlSumStatsFromZMatrix(z, study = "s1", ldSketch = .qszm_gh()), "column names") }) + +# =========================================================================== +# qtlSumStatsFromBetaMatrix (beta-scale sibling of qtlSumStatsFromZMatrix) +# =========================================================================== + +.qszmBeta <- function() { + rn <- c("chr1:100:A:G", "chr1:200:C:T", "chr2:50:A:T") + cn <- c("brain", "liver") + list(bhat = matrix(c(0.5, -0.3, 0.2, 0.1, 0.4, -0.6), nrow = 3, + dimnames = list(rn, cn)), + shat = matrix(c(0.1, 0.2, 0.15, 0.12, 0.09, 0.2), nrow = 3, + dimnames = list(rn, cn))) +} + +test_that("qtlSumStatsFromBetaMatrix: one entry per context, BETA/SE/Z mcols set", { + d <- .qszmBeta() + qss <- qtlSumStatsFromBetaMatrix(d$bhat, d$shat, study = "s1", + ldSketch = .qszm_gh()) + expect_s4_class(qss, "QtlSumStats") + expect_equal(nrow(qss), 2L) + expect_equal(as.character(qss$context), c("brain", "liver")) + mc <- S4Vectors::mcols(qss$entry[[1]]) + expect_true(all(c("BETA", "SE", "Z") %in% colnames(mc))) + expect_equal(mc$BETA, unname(d$bhat[, 1])) + expect_equal(mc$SE, unname(d$shat[, 1])) + expect_equal(mc$Z, unname(d$bhat[, 1] / d$shat[, 1])) +}) + +test_that("qtlSumStatsFromBetaMatrix: feeds .mashSumStatsToMatrices on both scales", { + d <- .qszmBeta() + qss <- qtlSumStatsFromBetaMatrix(d$bhat, d$shat, study = "s1", + ldSketch = .qszm_gh()) + mb <- .mashSumStatsToMatrices(qss, "strong", inputScale = "beta") + expect_equal(unname(mb$b), unname(d$bhat)) + expect_equal(unname(mb$s), unname(d$shat)) + mz <- .mashSumStatsToMatrices(qss, "strong", inputScale = "z") + expect_equal(unname(mz$b), unname(d$bhat / d$shat)) +}) + +test_that("qtlSumStatsFromBetaMatrix: validates matrices and matching dimensions", { + d <- .qszmBeta() + expect_error(qtlSumStatsFromBetaMatrix(1:5, d$shat, "s1", .qszm_gh()), + "`bhat` must be a numeric") + expect_error(qtlSumStatsFromBetaMatrix(d$bhat, 1:5, "s1", .qszm_gh()), + "`shat` must be a numeric") + expect_error(qtlSumStatsFromBetaMatrix(d$bhat, d$shat[1:2, ], "s1", .qszm_gh()), + "identical dimensions") +}) + +test_that("qtlSumStatsFromBetaMatrix: NULL rownames -> synthetic ids; placeholders set", { + bhat <- matrix(rnorm(4), nrow = 2, dimnames = list(NULL, c("x", "y"))) + shat <- matrix(abs(rnorm(4)) + 0.1, nrow = 2, dimnames = list(NULL, c("x", "y"))) + qss <- qtlSumStatsFromBetaMatrix(bhat, shat, study = "s1", ldSketch = .qszm_gh(), + n = 500L, a1 = "T", a2 = "C", role = "strong") + mc <- S4Vectors::mcols(qss$entry[[1]]) + expect_equal(mc$SNP, c("var1", "var2")) + expect_equal(unique(mc$A1), "T") + expect_equal(unique(mc$N), 500L) + expect_equal(qss@qcInfo$role, "strong") +}) + +# =========================================================================== +# mashInput (unified strong/random/null assembly from S4 objects) +# =========================================================================== + +# A multi-context QtlFineMappingResult fixture: two contexts sharing the same +# 6 variants, each with one credible set whose lead (max PIP) is a distinct +# variant, plus low-signal background for random/null sampling. +.mi_makeFmr <- function() { + mkTL <- function(zvec, csIdx) { + n <- length(zvec) + data.frame( + variant_id = paste0("chr1:", 100 * seq_len(n), ":A:G"), + chrom = "1", pos = as.integer(100 * seq_len(n)), A1 = "G", A2 = "A", + N = 1000, MAF = 0.2, + marginal_beta = zvec * 0.05, marginal_se = 0.05, marginal_z = zvec, + marginal_p = 2 * pnorm(-abs(zvec)), + pip = { p <- rep(0.05, n); p[csIdx] <- seq(0.9, by = -0.2, + length.out = length(csIdx)); p }, + posterior_mean = zvec * 0.05, posterior_sd = 0.02, + cs_95 = { cc <- rep("susie_0", n); cc[csIdx] <- "susie_1"; cc }, + stringsAsFactors = FALSE) + } + vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") + e1 <- FineMappingEntry(variantIds = vids, susieFit = list(x = 1), + topLoci = mkTL(c(0.5, -1, 6.0, 0.2, 1.1, -0.3), c(3, 2))) + e2 <- FineMappingEntry(variantIds = vids, susieFit = list(x = 1), + topLoci = mkTL(c(-0.4, 0.7, 0.1, 5.0, -1.2, 0.6), c(4, 5))) + QtlFineMappingResult(study = c("s1", "s1"), context = c("brain", "blood"), + trait = c("t1", "t1"), method = c("susie", "susie"), + entry = list(e1, e2)) +} + +test_that("mashInput: QtlSumStats path returns the flat b/s/z + XtX contract", { + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + out <- mashInput(list(geneA = ss), nRandom = 5, nNull = 5, seed = 1) + for (k in c("strong.b", "strong.s", "strong.z", "random.b", "random.s", + "random.z", "null.b", "null.s", "null.z", "XtX")) { + expect_true(k %in% names(out), info = k) + } + nCond <- ncol(out$strong.z) + expect_equal(nrow(out$random.z), 5L) + expect_equal(nrow(out$null.z), 5L) + # XtX is conditions x conditions and symmetric + expect_equal(dim(out$XtX), c(nCond, nCond)) + expect_equal(unname(out$XtX), unname(t(out$XtX))) +}) + +test_that("mashInput: FineMappingResult strong = CS lead (max PIP) per condition", { + fmr <- .mi_makeFmr() + out <- mashInput(list(geneA = fmr), nRandom = 4, nNull = 4, coverage = 0.95, + sigPCutoff = 0.5, seed = 7) + expect_equal(colnames(out$strong.z), c("brain", "blood")) + # brain CS lead = variant 3 (chr1:300), blood CS lead = variant 4 (chr1:400) + expect_setequal(sub("_geneA$", "", rownames(out$strong.z)), + c("chr1:300:A:G", "chr1:400:A:G")) + expect_equal(nrow(out$random.z), 4L) +}) + +test_that("mashInput: a FineMappingResult with no credible set yields no strong", { + vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") + noCsTL <- function(zvec) data.frame( + variant_id = vids, chrom = "1", pos = as.integer(100 * seq_len(6)), + A1 = "G", A2 = "A", N = 1000, MAF = 0.2, + marginal_beta = zvec * 0.05, marginal_se = 0.05, marginal_z = zvec, + marginal_p = 2 * pnorm(-abs(zvec)), + pip = rep(0.05, 6), posterior_mean = zvec * 0.05, posterior_sd = 0.02, + cs_95 = rep("susie_0", 6), stringsAsFactors = FALSE) + e1 <- FineMappingEntry(variantIds = vids, susieFit = list(x = 1), + topLoci = noCsTL(rnorm(6))) + e2 <- FineMappingEntry(variantIds = vids, susieFit = list(x = 1), + topLoci = noCsTL(rnorm(6))) + fmr <- QtlFineMappingResult(study = c("s1", "s1"), + context = c("brain", "blood"), + trait = c("t1", "t1"), + method = c("susie", "susie"), entry = list(e1, e2)) + out <- mashInput(list(g = fmr), nRandom = 3, nNull = 3, seed = 2) + expect_null(out$strong.z) + expect_equal(nrow(out$random.z), 3L) +}) + +test_that("mashInput: multiple regions accumulate rows and disambiguate names", { + fmr <- .mi_makeFmr() + one <- mashInput(list(a = fmr), nRandom = 4, nNull = 4, sigPCutoff = 0.5, seed = 7) + two <- mashInput(list(a = fmr, b = fmr), nRandom = 4, nNull = 4, + sigPCutoff = 0.5, seed = 7) + expect_equal(nrow(two$strong.z), 2L * nrow(one$strong.z)) + expect_equal(nrow(two$random.z), 2L * nrow(one$random.z)) + expect_false(any(duplicated(rownames(two$random.z)))) +}) + +test_that("mashInput: zOnly = TRUE drops the .b/.s matrices", { + fmr <- .mi_makeFmr() + out <- mashInput(list(g = fmr), nRandom = 3, nNull = 3, zOnly = TRUE, + sigPCutoff = 0.5, seed = 7) + expect_false(any(grepl("\\.(b|s)$", names(out)))) + expect_true(all(c("strong.z", "random.z", "null.z", "XtX") %in% names(out))) +}) + +test_that("mashInput: excludeCondition drops the condition column everywhere", { + # Exclude one of three conditions (mash needs >= 2), leaving brain + blood. + data(qtl_sumstats_multicontext_example) + ss <- qtl_sumstats_multicontext_example + out <- mashInput(list(g = ss), nRandom = 4, nNull = 4, + excludeCondition = "muscle", seed = 7) + expect_false("muscle" %in% colnames(out$random.z)) + expect_setequal(colnames(out$random.z), c("brain", "blood")) +}) + +test_that("mashInput: rejects a non-SumStats/non-FineMapping element", { + expect_error(mashInput(list(1L)), + "must be a QtlSumStats, GwasSumStats, or FineMappingResult") + expect_error(mashInput(list()), "non-empty list") +}) + +test_that("mashInput: independentVariants restricts random/null pool (strong untouched)", { + fmr <- .mi_makeFmr() # 6 variants chr1:100..600, 2 contexts + vids <- paste0("chr1:", 100 * seq_len(6), ":A:G") + indep <- vids[1:3] # only the first three are "independent" + out <- mashInput(list(g = fmr), nRandom = 3, nNull = 3, + independentVariants = indep, sigPCutoff = 0.5, seed = 7) + # random / null variant ids (strip the "_g" region suffix) must lie in indep. + rn_ids <- sub("_g$", "", rownames(out$random.z)) + expect_true(length(rn_ids) > 0L && all(rn_ids %in% indep)) + if (!is.null(out$null.z)) { + expect_true(all(sub("_g$", "", rownames(out$null.z)) %in% indep)) + } + # strong is NOT filtered -- its CS lead may lie outside the independent set. + expect_true(nrow(out$strong.z) >= 1L) +}) + +test_that("mashInput: independentVariants matches across allele flip + chr prefix", { + fmr <- .mi_makeFmr() + # same positions as the first three variants, but ref/alt swapped and the + # chr prefix dropped -- matchVariants must still match them (not a string cmp). + indep_flipped <- c("1:100:G:A", "1:200:G:A", "1:300:G:A") + out <- mashInput(list(g = fmr), nRandom = 3, nNull = 3, + independentVariants = indep_flipped, sigPCutoff = 0.5, seed = 7) + rn_ids <- sub("_g$", "", rownames(out$random.z)) + expect_true(length(rn_ids) > 0L) + expect_true(all(rn_ids %in% paste0("chr1:", c(100, 200, 300), ":A:G"))) +}) diff --git a/tests/testthat/test_overlapTopLoci.R b/tests/testthat/test_overlapTopLoci.R new file mode 100644 index 00000000..e39e3cd7 --- /dev/null +++ b/tests/testthat/test_overlapTopLoci.R @@ -0,0 +1,97 @@ +context("overlapTopLoci") + +# Minimal top-loci frame (the FineMappingEntry slot schema). +.ot_tl <- function(vids, A1, A2, pm, af, cs = "susie_1") { + n <- length(vids) + p <- pecotmr:::parseVariantId(vids) + data.frame( + variant_id = vids, chrom = p$chrom, pos = as.integer(p$pos), + A1 = A1, A2 = A2, N = rep(1000, n), af = af, + marginal_beta = NA_real_, marginal_se = NA_real_, + marginal_z = NA_real_, marginal_p = NA_real_, + pip = rep(0.9, n), posterior_mean = pm, posterior_sd = rep(0.02, n), + cs_95 = rep(cs, n), cs_95_purity = rep(0.9, n), + stringsAsFactors = FALSE) +} +.ot_entry <- function(tl) FineMappingEntry(variantIds = tl$variant_id, + susieFit = list(fake = TRUE), topLoci = tl) + +test_that("overlapTopLoci joins QTL x GWAS with allele-aware matching + sign-flip", { + # QTL: two contexts, variants v1 (chr1:100:A:G) and v2 (chr1:200:A:G). + q1 <- .ot_entry(.ot_tl(c("chr1:100:A:G", "chr1:200:A:G"), + A1 = c("G", "G"), A2 = c("A", "A"), pm = c(0.30, 0.40), + af = c(0.3, 0.4))) + q2 <- .ot_entry(.ot_tl(c("chr1:100:A:G", "chr1:200:A:G"), + A1 = c("G", "G"), A2 = c("A", "A"), pm = c(0.20, 0.25), + af = c(0.3, 0.4))) + qtl <- QtlFineMappingResult(study = c("s", "s"), context = c("ctx1", "ctx2"), + trait = c("t", "t"), method = c("susie", "susie"), + entry = list(q1, q2)) + # GWAS: v1 same orientation; v2 REF/ALT-SWAPPED (chr1:200:G:A). + g1 <- .ot_entry(.ot_tl(c("chr1:100:A:G", "chr1:200:G:A"), + A1 = c("G", "A"), A2 = c("A", "G"), pm = c(0.60, 0.50), + af = c(0.2, 0.7))) + gwas <- GwasFineMappingResult(study = "gwas", method = "susie", entry = list(g1)) + + ov <- overlapTopLoci(qtl, gwas, signalCutoff = 0) + + # variant key kept once; every other column prefixed qtl_ / gwas_ + expect_true(all(c("variant_id", "chrom", "pos", "A1", "A2") %in% names(ov))) + expect_true(any(grepl("^qtl_", names(ov))) && any(grepl("^gwas_", names(ov)))) + expect_false(any(grepl("^qtl_(chrom|pos|A1|A2)$", names(ov)))) + # 2 shared variants x 2 QTL contexts x 1 GWAS study = 4 rows (wide cross-product) + expect_equal(nrow(ov), 4L) + expect_setequal(unique(ov$variant_id), c("chr1:100:A:G", "chr1:200:A:G")) + # per-context QTL rows preserved + expect_setequal(unique(ov$qtl_context), c("ctx1", "ctx2")) + + # v1 unflipped: gwas beta unchanged (+0.6); v2 swapped: sign-flipped (-0.5) + v1 <- ov[ov$variant_id == "chr1:100:A:G", ] + v2 <- ov[ov$variant_id == "chr1:200:A:G", ] + expect_true(all(abs(v1$gwas_beta - 0.60) < 1e-9)) + expect_true(all(abs(v2$gwas_beta + 0.50) < 1e-9)) + # af complemented on the swapped variant (0.7 -> 0.3), untouched otherwise + expect_true(all(abs(v2$gwas_af - 0.30) < 1e-9)) + expect_true(all(abs(v1$gwas_af - 0.20) < 1e-9)) +}) + +test_that("overlapTopLoci returns zero rows when no variants overlap", { + q <- .ot_entry(.ot_tl("chr1:100:A:G", A1 = "G", A2 = "A", pm = 0.3, af = 0.3)) + g <- .ot_entry(.ot_tl("chr2:999:C:T", A1 = "T", A2 = "C", pm = 0.6, af = 0.2)) + qtl <- QtlFineMappingResult(study = "s", context = "c", trait = "t", + method = "susie", entry = list(q)) + gwas <- GwasFineMappingResult(study = "g", method = "susie", entry = list(g)) + ov <- overlapTopLoci(qtl, gwas, signalCutoff = 0) + expect_equal(nrow(ov), 0L) + expect_true(any(grepl("^qtl_", names(ov))) && any(grepl("^gwas_", names(ov)))) +}) + +test_that("overlapTopLoci returns an empty merge when a side has no signal (df + GRanges)", { + q <- .ot_entry(.ot_tl("chr1:100:A:G", A1 = "G", A2 = "A", pm = 0.3, af = 0.3)) + g <- .ot_entry(.ot_tl("chr1:100:A:G", A1 = "G", A2 = "A", pm = 0.6, af = 0.2)) + qtl <- QtlFineMappingResult(study = "s", context = "c", trait = "t", + method = "susie", entry = list(q)) + gwas <- GwasFineMappingResult(study = "g", method = "susie", entry = list(g)) + # signalCutoff above every pip (0.9) -> both top-loci tables empty -> emptyMerge. + df <- overlapTopLoci(qtl, gwas, signalCutoff = 0.99) + expect_equal(nrow(df), 0L) + expect_true(any(grepl("^qtl_", names(df))) && any(grepl("^gwas_", names(df)))) + # same empty result routed through the GRanges branch (.overlapToGRanges empty guard). + gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0.99, type = "GRanges") + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 0L) +}) + +test_that("overlapTopLoci type='GRanges' returns a GRanges of the shared variants", { + q <- .ot_entry(.ot_tl(c("chr1:100:A:G", "chr1:200:A:G"), + A1 = c("G", "G"), A2 = c("A", "A"), pm = c(0.3, 0.4), + af = c(0.3, 0.4))) + g <- .ot_entry(.ot_tl("chr1:100:A:G", A1 = "G", A2 = "A", pm = 0.6, af = 0.2)) + qtl <- QtlFineMappingResult(study = "s", context = "c", trait = "t", + method = "susie", entry = list(q)) + gwas <- GwasFineMappingResult(study = "g", method = "susie", entry = list(g)) + gr <- overlapTopLoci(qtl, gwas, signalCutoff = 0, type = "GRanges") + expect_s4_class(gr, "GRanges") + expect_equal(length(gr), 1L) + expect_true("gwas_beta" %in% names(S4Vectors::mcols(gr))) +}) diff --git a/tests/testthat/test_qtlAssociationPostprocess.R b/tests/testthat/test_qtlAssociationPostprocess.R new file mode 100644 index 00000000..67cb085d --- /dev/null +++ b/tests/testthat/test_qtlAssociationPostprocess.R @@ -0,0 +1,323 @@ +context("qtlAssociationPostprocess") + +# A deterministic per-gene QtlSumStats: one row per gene carrying the regional +# summary as row columns (p_beta / beta shapes / n_variants), each entry a +# per-variant GRanges (P / af / tss_distance / tes_distance). Deterministic so +# qvalue::qvalue sees a stable p-value distribution. +# drop row columns to omit (e.g. "n_variants", "p_beta", beta shapes), +# for the required-column / missing-input error paths. +# withQvalue attach a per-variant `qvalue` mcol (needed by the qvalue SNP +# significance query), with v1 tracking the gene signal. +# emptyIdx gene indices whose entry is an empty GRanges (no p-values), for +# the "skip genes with no variants" branch. +# naShapeIdx gene indices given an NA beta_shape1 (so qbeta -> NA nominal +# threshold), for the "skip genes with an NA threshold" branch. +# Column counts and the p_beta distribution are unchanged from the base +# fixture, so qvalue::qvalue still estimates pi0 on its default path. +.qapFixture <- function(nVar = 50L, nVarFilt = 30L, drop = character(), + withQvalue = FALSE, emptyIdx = integer(0), + naShapeIdx = integer(0)) { + # 6 strong signal p_beta + a deterministic uniform null (ppoints) so + # qvalue::qvalue estimates pi0 on its default path (no fallback needed). + pBeta <- c(10^(-c(8, 7, 6, 5, 4, 3)), stats::ppoints(54)) + G <- length(pBeta) + entries <- lapply(seq_len(G), function(i) { + if (i %in% emptyIdx) return(GenomicRanges::GRanges()) # no variants + k <- 4L + pv <- c(pBeta[i] / 5, 0.2, 0.5, 0.8) # min tracks the gene signal + gr <- GenomicRanges::GRanges("chr1", + IRanges::IRanges(start = seq(1000L, by = 50L, length.out = k), width = 1L)) + mc <- S4Vectors::DataFrame( + SNP = paste0("g", i, "_v", seq_len(k)), A1 = "A", A2 = "G", + P = pv, af = c(0.30, 0.20, 0.005, 0.40), # v3 fails MAF 0.01 + tss_distance = c(0L, 500L, 900000L, 2000000L), # v4 outside 1Mb cis + tes_distance = c(0L, 500L, 900000L, 2000000L)) + if (withQvalue) mc$qvalue <- c(pBeta[i] / 5, 0.30, 0.60, 0.90) + S4Vectors::mcols(gr) <- mc + gr + }) + shape1 <- rep(1, G); shape1[naShapeIdx] <- NA_real_ + args <- list( + study = rep("s", G), context = rep("brain", G), + trait = paste0("g", seq_len(G)), entry = entries, genome = "hg19", + n_variants = rep(nVar, G), n_variants_filtered = rep(nVarFilt, G), + p_beta = pBeta, beta_shape1 = shape1, beta_shape2 = rep(200, G)) + do.call(QtlSumStats, args[setdiff(names(args), drop)]) +} + +test_that("qtlAssociationPostprocess enriches with package-computed columns", { + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, fdrThreshold = 0.1, + mafCutoff = 0.01, cisWindow = 1e6) + + expect_s4_class(r, "QtlSumStats") + expect_false(is.null(r@qcInfo$associationPostprocess)) # recipe stashed + + # Bonferroni original == min over variants of p.adjust(P, "bonferroni", n). + expP <- vapply(seq_len(nrow(x)), function(i) + min(stats::p.adjust(S4Vectors::mcols(x$entry[[i]])$P, "bonferroni", n = 50)), + numeric(1)) + expect_equal(as.numeric(r$p_bonferroni_min_original), expP) + expect_equal(as.numeric(r$fdr_bonferroni_min_original), + stats::p.adjust(expP, "fdr")) + expect_true(all(r$q_bonferroni_min_original >= 0 & + r$q_bonferroni_min_original <= 1)) + + # Filtered flavour present and uses the smaller test count (n_variants_filtered). + expect_true(all(c("p_bonferroni_min_filtered", "fdr_bonferroni_min_filtered", + "q_bonferroni_min_filtered") %in% names(r))) +}) + +test_that("q-values come from qvalue::qvalue, not a hand-rolled fallback", { + skip_if_not_installed("qvalue") + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, methods = "permutation") + expect_equal(as.numeric(r$q_beta), + qvalue::qvalue(as.numeric(x$p_beta))$qvalues) + expect_equal(as.numeric(r$fdr_beta), + stats::p.adjust(as.numeric(x$p_beta), "fdr")) +}) + +test_that("permutation nominal threshold == stats::qbeta of the empirical cutoff", { + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, fdrThreshold = 0.1, methods = "permutation") + qb <- as.numeric(r$q_beta) + pb <- as.numeric(x$p_beta) + lb <- sort(pb[qb <= 0.1]); ub <- sort(pb[qb > 0.1]) + expect_gt(length(lb), 0) + thr <- if (length(ub) > 0) (lb[length(lb)] + ub[1]) / 2 else lb[length(lb)] + expect_equal(as.numeric(r$p_nominal_threshold), + stats::qbeta(thr, rep(1, nrow(x)), rep(200, nrow(x)))) +}) + +test_that("getSignificantQtls (bonferroni) matches the derived threshold rule", { + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6) + sig <- getSignificantQtls(r, "bonferroni_original", threshold = 0.5) + expect_s4_class(sig, "GRanges") + expect_true("trait" %in% names(S4Vectors::mcols(sig))) + + # Reproduce the rule: variants with P*n_variants <= max(p_bonf_min over FDR-sig genes). + fdr <- as.numeric(r$fdr_bonferroni_min_original) + sigGenes <- which(fdr < 0.5) + expect_gt(length(sigGenes), 0) + varThr <- max(as.numeric(r$p_bonferroni_min_original)[sigGenes]) + expN <- sum(vapply(seq_len(nrow(r)), function(i) + sum(pmin(1, S4Vectors::mcols(r$entry[[i]])$P * 50) <= varThr), integer(1))) + expect_equal(length(sig), expN) +}) + +test_that("getSumStats(annotateSignificance=) adds a derived logical mcol", { + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, methods = "permutation") + gr <- getSumStats(r, study = "s", context = "brain", trait = "g1", + annotateSignificance = "permutation") + expect_true("significant" %in% names(S4Vectors::mcols(gr))) + expect_type(S4Vectors::mcols(gr)$significant, "logical") + # matches the permutation rule P < p_nominal_threshold[gene 1] + thr1 <- as.numeric(r$p_nominal_threshold)[1] + exp1 <- if (is.na(thr1)) rep(FALSE, length(gr)) else + S4Vectors::mcols(gr)$P < thr1 + expect_equal(S4Vectors::mcols(gr)$significant, exp1) +}) + +test_that("significance accessors require a postprocessed object", { + x <- .qapFixture() # not postprocessed + expect_error(getSignificantQtls(x, "bonferroni_original"), + "qtlAssociationPostprocess") +}) + +# ---- qvalue-native edge-case retries (the ONLY substitute is qvalue itself) -- +# The fixture carries p_beta but no q_beta, so permutation postprocessing routes +# q_beta through .qapSafeQvalue -> qvalue::qvalue. Mock qvalue to raise each +# qvalue-native error on the primary (no-lambda) call and succeed on the retry +# (lambda supplied), then assert the retry value flows through unchanged. + +test_that(".qapSafeQvalue retries with lambda=0 on qvalue 'missing or infinite'", { + skip_if_not_installed("qvalue") + testthat::local_mocked_bindings( + qvalue = function(p, lambda, ...) { + if (missing(lambda)) stop("missing or infinite values in the smoother") + list(qvalues = rep(0.111, length(p))) + }, .package = "qvalue") + r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + expect_true(all(as.numeric(r$q_beta) == 0.111)) +}) + +test_that(".qapSafeQvalue retries with bootstrap pi0 on qvalue 'pi0 <= 0'", { + skip_if_not_installed("qvalue") + testthat::local_mocked_bindings( + qvalue = function(p, lambda, ...) { + if (missing(lambda)) stop("ERROR: The estimated pi0 <= 0.") + list(qvalues = rep(0.222, length(p))) + }, .package = "qvalue") + r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") + expect_true(all(as.numeric(r$q_beta) == 0.222)) +}) + +test_that(".qapSafeQvalue re-raises a non-native qvalue error (no hand-rolled q)", { + skip_if_not_installed("qvalue") + testthat::local_mocked_bindings( + qvalue = function(p, ...) stop("some unrelated numerical failure"), + .package = "qvalue") + expect_error( + qtlAssociationPostprocess(.qapFixture(), methods = "permutation"), + "qvalue::qvalue failed") +}) + +test_that("permutation nominal threshold is NA for every gene when none pass FDR", { + # An impossibly small FDR threshold leaves no q_beta-significant gene, so the + # empirical p_beta bracketing is empty and every nominal threshold is NA. + r <- qtlAssociationPostprocess(.qapFixture(), fdrThreshold = 1e-300, + methods = "permutation") + expect_true(all(is.na(as.numeric(r$p_nominal_threshold)))) +}) + +# ---- getSignificantQtls: one branch of the significance mask per method ------- + +test_that("getSignificantQtls (permutation) uses each gene's nominal threshold", { + r <- qtlAssociationPostprocess(.qapFixture(), fdrThreshold = 0.1, + methods = "permutation") + sig <- getSignificantQtls(r, "permutation") # threshold defaults to recipe + expect_s4_class(sig, "GRanges") + expect_true("trait" %in% names(S4Vectors::mcols(sig))) + # Reproduce: per gene, variants with P < p_nominal_threshold[gene]. + thr <- as.numeric(r$p_nominal_threshold) + expN <- sum(vapply(seq_len(nrow(r)), function(i) { + if (is.na(thr[i])) return(0L) + sum(S4Vectors::mcols(r$entry[[i]])$P < thr[i]) + }, integer(1))) + expect_gt(expN, 0) + expect_equal(length(sig), expN) +}) + +test_that("getSignificantQtls (permutation) skips genes with an NA threshold", { + # Gene 1's NA beta_shape1 makes its qbeta nominal threshold NA, so the mask + # loop must `next` past it while still processing the non-NA genes. + r <- qtlAssociationPostprocess(.qapFixture(naShapeIdx = 1L), + fdrThreshold = 0.1, methods = "permutation") + thr <- as.numeric(r$p_nominal_threshold) + expect_true(is.na(thr[1])) # NA-threshold gene present ... + expect_true(any(!is.na(thr))) # ... alongside non-NA genes + sig <- getSignificantQtls(r, "permutation") + expect_s4_class(sig, "GRanges") + # Gene 1 contributes nothing; total is the sum over the non-NA-threshold genes. + expN <- sum(vapply(seq_len(nrow(r)), function(i) { + if (is.na(thr[i])) return(0L) + sum(S4Vectors::mcols(r$entry[[i]])$P < thr[i]) + }, integer(1))) + expect_equal(length(sig), expN) +}) + +test_that("getSignificantQtls (permutation) errors without a nominal threshold", { + # No beta shapes -> postprocess produces no p_nominal_threshold column. + r <- qtlAssociationPostprocess( + .qapFixture(drop = c("beta_shape1", "beta_shape2")), methods = "permutation") + expect_null(r$p_nominal_threshold) + expect_error(getSignificantQtls(r, "permutation"), "p_nominal_threshold") +}) + +test_that("getSignificantQtls (bonferroni_filtered) applies the MAF/cis keep filter", { + r <- qtlAssociationPostprocess(.qapFixture(), mafCutoff = 0.01, cisWindow = 1e6) + sig <- getSignificantQtls(r, "bonferroni_filtered", threshold = 0.5) + expect_s4_class(sig, "GRanges") + expect_gt(length(sig), 0) + # Every returned variant must satisfy the filtered keep rule (MAF & cis window). + af <- S4Vectors::mcols(sig)$af + expect_true(all(pmin(af, 1 - af) > 0.01)) + expect_true(all(S4Vectors::mcols(sig)$tss_distance >= -1e6 & + S4Vectors::mcols(sig)$tes_distance <= 1e6)) +}) + +test_that("getSignificantQtls (bonferroni) errors when its columns are absent", { + r <- qtlAssociationPostprocess(.qapFixture(), methods = "permutation") # no bonferroni + expect_error(getSignificantQtls(r, "bonferroni_original"), "columns absent") +}) + +test_that("getSignificantQtls (qvalue) selects variants by their qvalue mcol", { + skip_if_not_installed("qvalue") + r <- qtlAssociationPostprocess(.qapFixture(withQvalue = TRUE), + fdrThreshold = 0.1, methods = "permutation") + sig <- getSignificantQtls(r, "qvalue", threshold = 0.1) + expect_s4_class(sig, "GRanges") + # Reproduce: within genes whose event q_beta < 0.1, variants with qvalue < 0.1. + qb <- as.numeric(r$q_beta) + sigGenes <- which(qb < 0.1) + expect_gt(length(sigGenes), 0) + expN <- sum(vapply(sigGenes, function(i) + sum(S4Vectors::mcols(r$entry[[i]])$qvalue < 0.1), integer(1))) + expect_gt(expN, 0) + expect_equal(length(sig), expN) +}) + +test_that("getSignificantQtls (qvalue) errors when no event q column exists", { + # Drop p_beta so permutation adds no q_beta, and skip bonferroni so there is + # no q_bonferroni_min_original either -- yet the object is still postprocessed. + r <- qtlAssociationPostprocess(.qapFixture(drop = "p_beta"), methods = "permutation") + expect_null(r$q_beta) + expect_null(r$q_bonferroni_min_original) + expect_error(getSignificantQtls(r, "qvalue"), "event q-value column") +}) + +test_that("getSignificantQtls returns an empty GRanges when nothing is significant", { + r <- qtlAssociationPostprocess(.qapFixture(), mafCutoff = 0.01, cisWindow = 1e6) + sig <- getSignificantQtls(r, "bonferroni_original", threshold = 1e-300) + expect_s4_class(sig, "GRanges") + expect_length(sig, 0) +}) + +# ---- qtlAssociationPostprocess: required-column + empty-entry guards ---------- + +test_that("qtlAssociationPostprocess requires n_variants for Bonferroni", { + expect_error( + qtlAssociationPostprocess(.qapFixture(drop = "n_variants"), methods = "bonferroni"), + "required for the Bonferroni") +}) + +test_that("qtlAssociationPostprocess requires n_variants_filtered when filtering", { + expect_error( + qtlAssociationPostprocess(.qapFixture(drop = "n_variants_filtered"), + methods = "bonferroni", mafCutoff = 0.01), + "n_variants_filtered") +}) + +test_that("qtlAssociationPostprocess skips genes whose entry has no variants", { + r <- qtlAssociationPostprocess(.qapFixture(emptyIdx = 1L), methods = "bonferroni") + pmin1 <- as.numeric(r$p_bonferroni_min_original) + expect_true(is.na(pmin1[1])) # empty gene -> NA Bonferroni min + expect_true(all(!is.na(pmin1[-1]))) # every other gene is finite +}) + +test_that("FILTERED Bonferroni drops MAF/cis-failing variants + uses n_variants_filtered", { + # Fixture entries: af = (.30, .20, .005, .40), tss/tes_distance = (0, 500, 9e5, 2e6). + # With mafCutoff 0.01 + cisWindow 1e6 the filtered set keeps only v1, v2 + # (v3 fails MAF, v4 is outside the cis window); the filtered count is 30. + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6, + methods = "bonferroni") + P <- lapply(seq_len(nrow(x)), function(i) S4Vectors::mcols(x$entry[[i]])$P) + expFilt <- vapply(P, function(p) min(pmin(1, p[1:2] * 30)), numeric(1)) # v1,v2 @ n=30 + expOrig <- vapply(P, function(p) min(pmin(1, p * 50)), numeric(1)) # all @ n=50 + expect_equal(as.numeric(r$p_bonferroni_min_filtered), expFilt) + expect_equal(as.numeric(r$p_bonferroni_min_original), expOrig) + # A smaller test count makes the filtered flavour no less significant. + expect_true(all(r$p_bonferroni_min_filtered <= r$p_bonferroni_min_original + 1e-12)) +}) + +test_that("getSignificantQtls(bonferroni_filtered) applies the derived rule on the filtered set", { + x <- .qapFixture() + r <- qtlAssociationPostprocess(x, mafCutoff = 0.01, cisWindow = 1e6, + methods = "bonferroni") + sig <- getSignificantQtls(r, "bonferroni_filtered", threshold = 0.5) + expect_s4_class(sig, "GRanges") + fdr <- as.numeric(r$fdr_bonferroni_min_filtered) + sigGenes <- which(!is.na(fdr) & fdr < 0.5) + expect_gt(length(sigGenes), 0) # signal genes pass + varThr <- max(as.numeric(r$p_bonferroni_min_filtered)[sigGenes]) + # only MAF/cis-passing variants (v1,v2) with P*n_filtered <= threshold qualify + expN <- sum(vapply(seq_len(nrow(r)), function(i) { + p <- S4Vectors::mcols(r$entry[[i]])$P[1:2] + sum(pmin(1, p * 30) <= varThr) + }, integer(1))) + expect_equal(length(sig), expN) +}) diff --git a/tests/testthat/test_qtlSumStats.R b/tests/testthat/test_qtlSumStats.R index d053f860..6cce50a1 100644 --- a/tests/testthat/test_qtlSumStats.R +++ b/tests/testthat/test_qtlSumStats.R @@ -77,6 +77,30 @@ test_that("QtlSumStats: multi-tuple object is keyed by (study, context, trait)", expect_equal(getTraits(obj), "t1") }) +test_that("QtlSumStats: getTraitPosition returns NA when no trait position supplied", { + obj <- .qtlMakeOne(trait = "ENSG001") + # traitPos cannot be inferred from summary statistics, so an unsupplied + # position reports NA rather than a fabricated range. + expect_identical(getTraitPosition(obj), NA) + expect_identical(getTraitPosition(obj, "ENSG001"), NA) +}) + +test_that("QtlSumStats: getTraitPosition returns the supplied trait position", { + tpos <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1000L, 1500L)) + obj <- QtlSumStats( + study = "s1", context = "c1", trait = "ENSGX", + entry = list(.qtlMakeEntryGr(5)), + genome = "hg19", ldSketch = .qtlMakeGenotypeHandle(), + traitPos = tpos) + tp <- getTraitPosition(obj) + expect_s4_class(tp, "GRanges") + expect_equal(GenomicRanges::start(tp), 1000L) + expect_equal(GenomicRanges::end(tp), 1500L) + expect_equal(GenomicRanges::start(getTraitPosition(obj, "ENSGX")), 1000L) + # a trait not in the collection -> NA + expect_identical(getTraitPosition(obj, "nope"), NA) +}) + test_that("QtlSumStats: errors when required args are missing", { expect_error(QtlSumStats(study = "s1", context = "c1"), "all required") @@ -322,3 +346,83 @@ test_that("getSumStats errors on an empty QtlSumStats collection", { expect_equal(nrow(empty), 0L) expect_error(getSumStats(empty), "has no rows") }) + +test_that("QtlSumStats: ldSketch is optional (NULL for LD-free workflows)", { + obj <- QtlSumStats( + study = "s1", context = "c1", trait = "t1", + entry = list(.qtlMakeEntryGr(1)), genome = "hg19") # ldSketch omitted + expect_null(getLdSketch(obj)) + expect_output(show(obj), "none \\(LD-free\\)") +}) + +test_that("QtlSumStats: a non-GenotypeHandle ldSketch is rejected", { + expect_error( + QtlSumStats(study = "s1", context = "c1", trait = "t1", + entry = list(.qtlMakeEntryGr(1)), genome = "hg19", + ldSketch = "not_a_handle"), + "GenotypeHandle or NULL") +}) + +# =========================================================================== +# First-class summary-statistic accessors: getP / getBeta / getSE +# =========================================================================== + +test_that("getP / getBeta / getSE read the optional P/BETA/SE mcols", { + gr <- .qtlMakeEntryGr(4) + S4Vectors::mcols(gr)$P <- c(0.1, 0.01, 1e-4, 0.5) + S4Vectors::mcols(gr)$BETA <- c(0.2, -0.3, 0.4, 0.05) + S4Vectors::mcols(gr)$SE <- rep(0.1, 4) + x <- QtlSumStats(study = "s", context = "c", trait = "g", + entry = list(gr), genome = "hg19") + expect_equal(getP(x), c(0.1, 0.01, 1e-4, 0.5)) + expect_equal(getBeta(x), c(0.2, -0.3, 0.4, 0.05)) + expect_equal(getSE(x), rep(0.1, 4)) +}) + +test_that("getP / getBeta / getSE return NULL when the entry omits them", { + y <- .qtlMakeOne(n = 4) # Z/N-only entry + expect_null(getP(y)) + expect_null(getBeta(y)) + expect_null(getSE(y)) + expect_equal(getZ(y), seq(1.0, by = 0.5, length.out = 4)) # Z still works +}) + +# =========================================================================== +# Constructor auto-fills tss_distance / tes_distance from traitPos +# =========================================================================== + +test_that("constructor derives tss/tes distance from a point trait position", { + gr <- .qtlMakeEntryGr(5, start_at = 100L, step = 100L) # 100..500 + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(250L, width = 1L)) + x <- QtlSumStats(study = "s", context = "c", trait = "g", + entry = list(gr), genome = "hg19", traitPos = tp) + mc <- S4Vectors::mcols(getSumStats(x)) + expect_equal(mc$tss_distance, c(100, 200, 300, 400, 500) - 250) + # 1bp trait -> tss and tes distance are identical + expect_equal(mc$tss_distance, mc$tes_distance) +}) + +test_that("constructor derives distinct tss/tes distance for a multi-base trait", { + gr <- .qtlMakeEntryGr(3, start_at = 100L, step = 100L) # 100,200,300 + tp <- GenomicRanges::GRanges("chr1", IRanges::IRanges(200L, 400L)) # TSS 200, TES 400 + x <- QtlSumStats(study = "s", context = "c", trait = "g", + entry = list(gr), genome = "hg19", traitPos = tp) + mc <- S4Vectors::mcols(getSumStats(x)) + expect_equal(mc$tss_distance, c(100, 200, 300) - 200) + expect_equal(mc$tes_distance, c(100, 200, 300) - 400) +}) + +test_that("no traitPos -> no distance columns; existing distance is preserved", { + z <- .qtlMakeOne(n = 3) + expect_null(S4Vectors::mcols(getSumStats(z))$tss_distance) + + gr <- .qtlMakeEntryGr(2, start_at = 100L, step = 100L) + S4Vectors::mcols(gr)$tss_distance <- c(-999L, -888L) # pre-existing + w <- QtlSumStats(study = "s", context = "c", trait = "g", + entry = list(gr), genome = "hg19", + traitPos = GenomicRanges::GRanges( + "chr1", IRanges::IRanges(250L, width = 1L))) + mc <- S4Vectors::mcols(getSumStats(w)) + expect_equal(mc$tss_distance, c(-999L, -888L)) # not clobbered + expect_equal(mc$tes_distance, c(100, 200) - 250) # absent -> filled +}) diff --git a/tests/testthat/test_sumstatsQc.R b/tests/testthat/test_sumstatsQc.R index 3f226e46..2141e07a 100644 --- a/tests/testthat/test_sumstatsQc.R +++ b/tests/testthat/test_sumstatsQc.R @@ -2328,7 +2328,7 @@ test_that("realistic LD: no outliers when z perfectly matches LD structure", { }) # ============================================================================ -# Internal function access (resolveLdInput via :::) +# Internal function access (resolveLdInput, pecotmr internal) # ============================================================================ test_that("resolveLdInput returns R when R is provided", { diff --git a/tests/testthat/test_tupleSelectors.R b/tests/testthat/test_tupleSelectors.R index 9d9a7d09..23dcf90e 100644 --- a/tests/testthat/test_tupleSelectors.R +++ b/tests/testthat/test_tupleSelectors.R @@ -301,3 +301,32 @@ test_that(".validateRegionColumn: reports a non-GRanges region column", { "'region' column must be a GRanges") expect_length(pecotmr:::.validateRegionColumn(S4Vectors::DataFrame(a = 1L)), 0L) }) + +test_that(".validateRegionColumn: reports a region column of the wrong length", { + # DataFrame [[<- enforces column length, so mutate @listData directly to build + # the malformed object the defensive validity check guards against. + bad <- S4Vectors::DataFrame(a = 1:2) # nrow 2 + bad@listData$region <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 1)) # length 1 + expect_equal(pecotmr:::.validateRegionColumn(bad), + "'region' column must have one range per row") +}) + +test_that(".appendTraitPosCol: traitPos must be a GRanges of matching length", { + expect_error(pecotmr:::.appendTraitPosCol(list(), "notgranges", 1L), + "must be a GRanges") + expect_error( + pecotmr:::.appendTraitPosCol(list(), + GenomicRanges::GRanges(c("chr1", "chr1"), IRanges::IRanges(1:2, 1:2)), 1L), + "same length as") +}) + +test_that(".validateTraitPosColumn: reports non-GRanges and wrong-length traitPos", { + expect_equal( + pecotmr:::.validateTraitPosColumn(S4Vectors::DataFrame(traitPos = c("x", "y"))), + "'traitPos' column must be a GRanges") + bad <- S4Vectors::DataFrame(a = 1:2) + bad@listData$traitPos <- GenomicRanges::GRanges("chr1", IRanges::IRanges(1, 1)) + expect_equal(pecotmr:::.validateTraitPosColumn(bad), + "'traitPos' column must have one range per row") + expect_length(pecotmr:::.validateTraitPosColumn(S4Vectors::DataFrame(a = 1L)), 0L) +}) diff --git a/tests/testthat/test_twasWeightsPipeline.R b/tests/testthat/test_twasWeightsPipeline.R index 60483db0..84acf020 100644 --- a/tests/testthat/test_twasWeightsPipeline.R +++ b/tests/testthat/test_twasWeightsPipeline.R @@ -177,13 +177,22 @@ test_that("twasWeightsPipeline(QtlDataset): runs end-to-end with mocked solvers" expect_equal(nrow(res), 4L) expect_setequal(getMethodNames(res), c("lasso", "enet")) expect_setequal(getTraits(res), c("ENSG_A", "ENSG_B")) - # region provenance is populated from each trait's rowRanges and aligned per - # row (.tp_makeSe: ENSG_A -> chr1:1000-1499, ENSG_B -> chr1:2000-2499). - reg <- getRegion(res) - expect_s4_class(reg, "GRanges") - expect_equal(length(reg), 4L) - expect_true(all(GenomicRanges::start(reg)[res$trait == "ENSG_A"] == 1000L)) - expect_true(all(GenomicRanges::start(reg)[res$trait == "ENSG_B"] == 2000L)) + # Provenance, aligned per row (.tp_makeSe: ENSG_A -> chr1:1000-1499, + # ENSG_B -> chr1:2000-2499). traitPos = the bare trait position (no + # cis-window); region = that position expanded by cisWindow (1000), start + # clamped at 1. + reg <- getRegion(res); tp <- getTraitPosition(res) + expect_s4_class(reg, "GRanges"); expect_s4_class(tp, "GRanges") + expect_equal(length(reg), 4L); expect_equal(length(tp), 4L) + # traitPos: the trait's own coordinates. + expect_true(all(GenomicRanges::start(tp)[res$trait == "ENSG_A"] == 1000L)) + expect_true(all(GenomicRanges::end(tp)[res$trait == "ENSG_A"] == 1499L)) + expect_true(all(GenomicRanges::start(tp)[res$trait == "ENSG_B"] == 2000L)) + # region: traitPos +/- cisWindow. + expect_true(all(GenomicRanges::start(reg)[res$trait == "ENSG_A"] == 1L)) # 1000-1000 -> clamp + expect_true(all(GenomicRanges::end(reg)[res$trait == "ENSG_A"] == 2499L)) # 1499+1000 + expect_true(all(GenomicRanges::start(reg)[res$trait == "ENSG_B"] == 1000L)) # 2000-1000 + expect_true(all(GenomicRanges::end(reg)[res$trait == "ENSG_B"] == 3499L)) # 2499+1000 }) test_that("twasWeightsPipeline(QtlDataset): mafCutoff/xvarCutoff overrides tighten the variant set", { diff --git a/tests/testthat/test_vcfWriter.R b/tests/testthat/test_vcfWriter.R index 1147c3d9..45f1a721 100644 --- a/tests/testthat/test_vcfWriter.R +++ b/tests/testthat/test_vcfWriter.R @@ -120,6 +120,28 @@ test_that("writeSumstatsVcf writes FineMappingResult to uncompressed VCF", { expect_gt(file.info(out)$size, 0) }) +test_that("writeSumstatsVcf(FineMappingResult): emits PIP + CS posterior FORMAT fields", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + + fm <- make_test_finemapping_result(5) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + writeSumstatsVcf(fm, out) + ln <- readLines(out) + # The posterior fields the legacy create_vcf carried must be present. The CS + # field is DYNAMIC (CS) -- the fixture carries cs_95 -> CS95. + expect_true(any(grepl("ID=PIP,", ln, fixed = TRUE))) + expect_true(any(grepl("ID=CS95,", ln, fixed = TRUE))) + data1 <- ln[!grepl("^#", ln)][[1L]] + fmtKeys <- strsplit(strsplit(data1, "\t")[[1L]][[9L]], ":")[[1L]] + expect_true("PIP" %in% fmtKeys) + expect_true("CS95" %in% fmtKeys) + # cs_95 "susie_" -> integer CS index; fixture row 1 is in CS 1. + vals <- strsplit(strsplit(data1, "\t")[[1L]][[10L]], ":")[[1L]] + expect_equal(vals[[which(fmtKeys == "CS95")]], "1") +}) + # ============================================================================= # FineMappingResult to BCF # ============================================================================= @@ -455,3 +477,47 @@ test_that("writeSumstatsVcf(FineMappingResult): emits AF from the topLoci `af` c expect_true(file.exists(out)) expect_true(any(grepl("ID=AF", readLines(out)))) }) + +test_that("writeSumstatsVcf(FineMappingResult): emits LBF / LFSR / PUR / fullFit FORMAT fields", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + # A rich topLoci exercises every posterior FORMAT field: per-variant logBF (LBF), + # local false sign rate (LFSR), per-CS purity (PUR), and the wide fullFit + # columns (within_cs_pip / cs_logbf_ / cs_effect_). + n <- 3 + tl <- data.frame( + variant_id = paste0("chr1:", c(100, 200, 300), ":T:A"), chrom = rep("1", n), + pos = c(100L, 200L, 300L), A1 = rep("A", n), A2 = rep("T", n), N = rep(1000, n), + marginal_beta = c(0.3, -0.2, 0.1), marginal_se = rep(0.05, n), + marginal_z = c(6, -4, 2), marginal_p = c(1e-9, 6e-5, 0.045), + pip = c(0.9, 0.7, 0.5), posterior_mean = rep(0.05, n), posterior_sd = rep(0.02, n), + logBF = c(3.1, 1.2, 0.4), lfsr = c(0.01, 0.2, 0.4), + cs_95 = paste0("susie_", c(1L, 0L, 2L)), cs_95_purity = c(0.95, 0, 0.88), + within_cs_pip = c(0.6, 0, 0.5), cs_logbf_susie_1 = c(2.2, NA, NA), + cs_effect_susie_1 = c(0.4, NA, NA), + stringsAsFactors = FALSE) + entry <- FineMappingEntry(variantIds = tl$variant_id, susieFit = list(), topLoci = tl) + fm <- GwasFineMappingResult(study = "s", method = "susie", entry = list(entry)) + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + writeSumstatsVcf(fm, out) + ln <- readLines(out) + for (id in c("ID=LBF", "ID=LFSR", "ID=PUR95", "ID=WITHIN_CS_PIP", + "ID=CS_LOGBF_SUSIE_1", "ID=CS_EFFECT_SUSIE_1")) + expect_true(any(grepl(id, ln, fixed = TRUE)), info = id) +}) + +test_that("writeSumstatsVcf(FineMappingResult): falls back to marginal sumstats when no posterior", { + skip_if_not_installed("VariantAnnotation") + skip_if_not_installed("Biostrings") + fm <- make_test_finemapping_result(5) + # Simulate an entry whose posterior table is unavailable (empty getTopLoci) so + # the marginal univariate sumstats alone drive the VCF body (the else-if branch). + testthat::local_mocked_bindings( + getTopLoci = function(x, ...) data.frame(), .package = "pecotmr") + out <- tempfile(fileext = ".vcf") + on.exit(unlink(out), add = TRUE) + writeSumstatsVcf(fm, out) + expect_true(file.exists(out)) + expect_true(any(grepl("ID=ES", readLines(out), fixed = TRUE))) # marginal beta -> ES +})